Question

（Sheet1）我有4列数据，每列都有不同数量的单元格。

在另一张纸（SHEET2）上，我有4个下拉框，上面列出了上面列的名称。

当我单击表2上的命令按钮时，我需要代码从与下拉框选择对应的列（sheet1）中选择一个随机单元格。然后，它需要将4个选定的单元格复制并粘贴到工作表2上的一个范围内。除此之外，我还需要将4个单元格连接到工作表2上的另一个单元格，每个单元格之间都有一个“，”。

下拉电池位于表2中的K8-K11中，随机电池粘贴在表2中的M8-M11中用于从中选择随机单元格的列是表1中的P-S（表2 K8 =表1列p =表2 M8等）

我的代码很长而且很笨重，我真的很想让它更加平稳，运行更顺畅，而且我确信有更好的方法可以做到这一点......：

Option Explicit

Private Sub CommandButton2_Click()
    Dim p As Range, q As Range, r As Range, s As Range
    Dim c As Collection, d As Collection, e As Collection, f As Collection
    Dim RNG1 As Range, RNG2 As Range, RNG3 As Range, RNG4 As Range
    Dim LastRow1 As Long, LastRow2 As Long, LastRow3 As Long, LastRow4 As Long
    Dim randomCell1 As Long, randomCell2 As Long, randomCell3 As Long, randomCell4 As Long
    Dim Names As String

    Worksheets("Contents").Activate

    ' Aoluwei's Blade
    Set c = New Collection
    LastRow1 = Worksheets("Contents").Range("P" & Rows.Count).End(xlUp).Row
    Set RNG1 = Worksheets("Contents").Range("P1:P" & LastRow1)

    For Each p In RNG1
        If p.Value <> "" Then c.Add p
    Next p
    Dim G As Long
    G = Application.WorksheetFunction.RandBetween(1, c.Count)
    c.Item(G).Copy
    Worksheets("Contents").Range("T2").PasteSpecial

    ' Canas Enlightenment
    Set d = New Collection
    LastRow2 = Worksheets("Contents").Range("Q" & Rows.Count).End(xlUp).Row
    Set RNG2 = Worksheets("Contents").Range("Q1:Q" & LastRow1)

    For Each q In RNG2
        If q.Value <> "" Then d.Add q
    Next q
    Dim H As Long
    H = Application.WorksheetFunction.RandBetween(1, d.Count)
    d.Item(H).Copy
    Worksheets("Contents").Range("T3").PasteSpecial

    ' Rangers Song
    Set e = New Collection
    LastRow3 = Worksheets("Contents").Range("R" & Rows.Count).End(xlUp).Row
    Set RNG3 = Worksheets("Contents").Range("R1:R" & LastRow1)

    For Each r In RNG3
        If r.Value <> "" Then e.Add r
    Next r
    Dim I As Long
    I = Application.WorksheetFunction.RandBetween(1, e.Count)
    Set rselect = e.Item(I)
    rselect.Copy
    Worksheets("Contents").Range("T4").PasteSpecial

    ' Abyss' Roar
    Set f = New Collection
    LastRow4 = Worksheets("Contents").Range("S" & Rows.Count).End(xlUp).Row
    Set RNG4 = Worksheets("Contents").Range("S1:S" & LastRow1)

    For Each s In RNG4
        If s.Value <> "" Then f.Add s
    Next s
    Dim J As Long
    J = Application.WorksheetFunction.RandBetween(1, f.Count)
    Set sselect = f.Item(J)
    sselect.Copy
    Worksheets("Contents").Range("T5").PasteSpecial
    Worksheets("Contents").Range("T2:T5").Copy
    Worksheets("Home").Activate
    Range("M8:M11").PasteSpecial

End Sub

任何帮助清理它都会很棒。我看了四周，但只能找到从1列中选择的代码....

将随机单元格复制到另一个工作表

0 个答案: