Pick random names from different lists excel VBA-CodePudding

I would like to pick random names from columns in excel like this :

-In the first sheet "Inscrp" is where the lists are, and the second sheet "Tirage" is where the results of the picking.

-Column A in the sheet "Tirage" should pick random names from column A in the sheet "Inscrp" and the same for the column B, C , till the number of columns I chose I managed to do this with only the first column and here is the code :

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

CodePudding user response：

Please, test the next code. If I correctly understand your nee, it will extract HowMany random numbers from each column (nrCol) of "Inscrip" sheet and placed starting from CellsOut in sheet "Tirage". The already extracted name is eliminated from the array where it used to exist (to avoid repeated names). The ranges ar placed in arrays and due to that, the code should be very fast mostly working in memory, even for large ranges:

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

If something unclear, do not hesitate to ask for clarifications...