从不同的列表中随机选择名称 excel VBA

Question

我想从 excel 中的列中随机选择名称，如下所示：

-第一个sheet“Inscrp”是列表所在的地方，第二个sheet“Tirage”是挑选结果的地方。

-sheet“Tirage”中的 A 列应该从 sheet“Inscrp”中的 A 列中随机选择名称，对于 B、C 列也是如此，直到列数我选择了我设法只用第一列做到了，这里是代码：

Sub PickNamesAtRandom()
Dim HowMany As Integer
Dim NoOfNames As Long
Dim RandomNumber As Integer
Dim Names() As String 'Array to store randomly selected names
Dim i As Byte
Dim CellsOut As Long 'Variable to be used when entering names onto worksheet
Dim ArI As Byte 'Variable to increment through array indexes
Application.ScreenUpdating = False

HowMany = 5
CellsOut = 8
ReDim Names(1 To HowMany) 'Set the array size to how many names required
NoOfNames = Application.CountA(Worksheets("Inscrp").Range("A3:A100")) - 1 ' Find how many names in the list
i = 1
Do While i <= HowMany
RandomNo:
    RandomNumber = Application.RandBetween(3, NoOfNames + 1)
    'Check to see if the name has already been picked
    For ArI = LBound(Names) To UBound(Names)
        If Names(ArI) = Worksheets("Inscrp").Cells(RandomNumber, 1).Value Then
            GoTo RandomNo
        End If
    Next ArI
    Names(i) = Worksheets("Inscrp").Cells(RandomNumber, 1).Value  ' Assign random name to the array
    i = i + 1
Loop
'Loop through the array and enter names onto the worksheet
For ArI = LBound(Names) To UBound(Names)
    Worksheets("Tirage").Cells(CellsOut, 1) = Names(ArI)
    CellsOut = CellsOut + 1
Next ArI

Application.ScreenUpdating = True
End Sub

Answer 1

请测试下一个代码。如果我正确理解你的 nee，它将从“Inscrip”sheet 的每一列 (nrCol) 中提取 HowMany 个随机数，并从 CellsOut 开始放置在 sheet 《蒂拉奇》。已经提取的名称从它曾经存在的数组中删除（以避免重复名称）。范围 ar 放置在数组中，因此，代码应该非常快，主要在内存中运行，即使对于大范围也是如此：

Sub PickNamesAtRandom()
 Dim shI As Worksheet, lastR As Long, shT As Worksheet, HowMany As Long
 Dim rndNumber As Integer, Names() As String, i As Long, CellsOut As Long

 HowMany = 5: CellsOut = 8
 Set shI = Worksheets("Inscrp")
 Set shT = Worksheets("Tirage")

 Dim col As Long, arrCol, filt As String, nrCol As Long
 nrCol = 2 'number of columns to be returned. It can be changed and also be calculated...

 For col = 1 To nrCol
    lastR = shI.cells(shI.rows.count, col).End(xlUp).Row 'last row in column to be processed
    If lastR >= HowMany + 2 Then '+ 2 because the range is build starting with the third row...
        arrCol = Application.Transpose(shI.Range(shI.cells(3, col), shI.cells(lastR, col)).Value2) 'place the range in a 1D array
        
        ReDim Names(1 To HowMany) 'Set the array size to how many names required
        For i = 1 To UBound(Names)
tryAgain:
            Randomize
            rndNumber = Int((UBound(arrCol) - LBound(arrCol) + 1) * Rnd + LBound(arrCol))
            If arrCol(rndNumber) = "" Then GoTo tryAgain
            Names(i) = arrCol(rndNumber)
            filt = arrCol(rndNumber) & "##$$@": arrCol(rndNumber) = filt
            arrCol = filter(arrCol, filt, False)   'eliminate the already used name from the array
        Next i
        shT.cells(CellsOut, col).Resize(UBound(Names), 1).Value2 = Application.Transpose(Names)
    End If
 Next col
 MsgBox "Ready..."
End Sub

如果有什么不清楚的地方，请不要犹豫，要求澄清...

从不同的列表中随机选择名称 excel VBA

Pick random names from different lists excel VBA

random

excel

vba