Count how many names in each column for random output

[youbitto]

I have two sheets


first is "Inscrp" where I put the names depending on categories in different columns Second is "Tirage" where I see random names appears from each category


HowMany = 5 in the code represent the number of names to be picked randomly The problem when I write less than 5 names the result would be empty.


I want the names to be picked randomly regardless of their number and prevent Hardcoding the "HowMany"


This is the code for it

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 = shT.Cells(4, 8) '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

Like this it returns only 5 names randomly from each filled column


Illustration :


In this case the column B in "Tirage" return empty because the HowMany I assigned is 5 names

------------------------------------Sheet1"Inscrp"-------------------------------------------------------------------------------------Sheet2"Tirage"

A​	B​	​	A​	B​
John​	Simon​	​	David​	"Nothing"​
David​	Gerard​	​	Steve​	​
Jacob​	Herald​	​	john​	​
Steve​	Paul​	​	Sara​	​
Sara​	​	​	Jacob​	​

​

This is how I want it :
------------------------------------Sheet1"Inscrp"-------------------------------------------------------------------------------------Sheet2"Tirage"

A​	B​	​	A​	B​
John​	Simon​	​	David​	Gerard​
David​	Gerard​	​	Steve​	Paul​
Jacob​	Herald​	​	john​	Simon​
Steve​	Paul​	​	Sara​	Herald​
Sara​	​	​	Jacob​	​

 

[youbitto]

So you don't want those empty cells?

yes I don't want them. I hope if they are skipped and the code look for the next filled cell or if it finds an empty cell it would re-randomize until it finds a name

 

[youbitto]

So you don't want those empty cells?

Try this:

Sub PickNamesAtRandom_2()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim nrCol As Long, i As Long, j As Long, x As Long, lr As Long
  Dim arr As Variant, y As Variant

  Set sh1 = Worksheets("Inscrp")
  Set sh2 = Worksheets("Tirage")
 
  nrCol = sh2.Range("H4").Value
  Randomize
 
  For j = 1 To nrCol
    lr = sh1.Cells(Rows.Count, j).End(3).Row
    If lr > 3 Then
      arr = sh1.Range(sh1.Cells(3, j), sh1.Cells(lr, j)).SpecialCells(xlCellTypeConstants).Value
      For i = 1 To UBound(arr, 1)
        x = Int(UBound(arr) * Rnd + 1)
        y = arr(x, 1)
        arr(x, 1) = arr(i, 1)
        arr(i, 1) = y
      Next
      sh2.Cells(8, j).Resize(UBound(arr, 1)).Value = arr
    End If
  Next
End Sub

Thank you very much, that's awesome

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.