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​	​

 

[DanteAmor]

Hi and welcome to MrExcel!

Try the following code:

Sub PickNamesAtRandom()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim nrCol As Long, HowMany As Long, CellsOut As Long
  Dim 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
  HowMany = 5
  CellsOut = 8
  Randomize
  
  For j = 1 To nrCol
    lr = WorksheetFunction.Max(sh1.Cells(Rows.Count, j).End(3).Row, HowMany + 2)
    arr = sh1.Range(sh1.Cells(3, j), sh1.Cells(lr, j)).Value
    For i = 1 To HowMany
      x = Int(UBound(arr) * Rnd + 1)
      y = arr(x, 1)
      arr(x, 1) = arr(i, 1)
      arr(i, 1) = y
    Next
    With sh2.Cells(CellsOut, j).Resize(HowMany)
      .Value = arr
      On Error Resume Next: .SpecialCells(xlCellTypeBlanks).Delete xlUp: On Error GoTo 0
    End With
  Next
End Sub

Note XL2BB:
For the future, it would help greatly if you could give us the sample data in a form that we can copy to test with, rather that a picture.

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

 

[youbitto]

Hi and welcome to MrExcel!

Try the following code:

Sub PickNamesAtRandom()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim nrCol As Long, HowMany As Long, CellsOut As Long
  Dim 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
  HowMany = 5
  CellsOut = 8
  Randomize
 
  For j = 1 To nrCol
    lr = WorksheetFunction.Max(sh1.Cells(Rows.Count, j).End(3).Row, HowMany + 2)
    arr = sh1.Range(sh1.Cells(3, j), sh1.Cells(lr, j)).Value
    For i = 1 To HowMany
      x = Int(UBound(arr) * Rnd + 1)
      y = arr(x, 1)
      arr(x, 1) = arr(i, 1)
      arr(i, 1) = y
    Next
    With sh2.Cells(CellsOut, j).Resize(HowMany)
      .Value = arr
      On Error Resume Next: .SpecialCells(xlCellTypeBlanks).Delete xlUp: On Error GoTo 0
    End With
  Next
End Sub

Note XL2BB:
For the future, it would help greatly if you could give us the sample data in a form that we can copy to test with, rather that a picture.

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

Hello!
The code works but it delete cells that are not used
Here are the sheets first sheet "Inscrp" where I write the names:

Vacance famille.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Terga							El Achouat
2	S1	S2	S3	S4	S5	S6		S1	S2	S3	S4	S5	S6
3				john	steve						john	herald
4				philip	sara						mark	bob
5				sara	charles							danny
6				omar								william
7				ali	carl
8				sofia								Jerry
9				eric
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Inscrp

And here the sheet where I should see the results:

Vacance famille.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1
2
3
4								84	Number Of Columns
5
6	Terga							El Achouat
7	S1	S2	S3	S4	S5	S6		S1	S2	S3	S4	S5	S6
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Tirage

 

[DanteAmor]

I used another way to remove the empty cells

Sub PickNamesAtRandom()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim nrCol As Long, HowMany As Long, CellsOut As Long
  Dim i As Long, j As Long, x As Long, lr As Long, z As Long
  Dim arr As Variant, y As Variant, arr2 As Variant

  Set sh1 = Worksheets("Inscrp")
  Set sh2 = Worksheets("Tirage")
  
  nrCol = sh2.Range("H4").Value
  HowMany = 5
  CellsOut = 8
  Randomize
  
  For j = 1 To nrCol
    lr = WorksheetFunction.Max(sh1.Cells(Rows.Count, j).End(3).Row, HowMany + 2)
    arr = sh1.Range(sh1.Cells(3, j), sh1.Cells(lr, j)).Value
    For i = 1 To HowMany
      x = Int(UBound(arr) * Rnd + 1)
      y = arr(x, 1)
      arr(x, 1) = arr(i, 1)
      arr(i, 1) = y
    Next
    ReDim arr2(1 To HowMany, 1 To 1)
    z = 0
    For i = 1 To HowMany
      If arr(i, 1) <> "" Then
        z = z + 1
        arr2(z, 1) = arr(i, 1)
      End If
    Next
    If z > 0 Then sh2.Cells(CellsOut, j).Resize(HowMany).Value = arr2
  Next
End Sub

 

[youbitto]

I used another way to remove the empty cells

Sub PickNamesAtRandom()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim nrCol As Long, HowMany As Long, CellsOut As Long
  Dim i As Long, j As Long, x As Long, lr As Long, z As Long
  Dim arr As Variant, y As Variant, arr2 As Variant

  Set sh1 = Worksheets("Inscrp")
  Set sh2 = Worksheets("Tirage")
 
  nrCol = sh2.Range("H4").Value
  HowMany = 5
  CellsOut = 8
  Randomize
 
  For j = 1 To nrCol
    lr = WorksheetFunction.Max(sh1.Cells(Rows.Count, j).End(3).Row, HowMany + 2)
    arr = sh1.Range(sh1.Cells(3, j), sh1.Cells(lr, j)).Value
    For i = 1 To HowMany
      x = Int(UBound(arr) * Rnd + 1)
      y = arr(x, 1)
      arr(x, 1) = arr(i, 1)
      arr(i, 1) = y
    Next
    ReDim arr2(1 To HowMany, 1 To 1)
    z = 0
    For i = 1 To HowMany
      If arr(i, 1) <> "" Then
        z = z + 1
        arr2(z, 1) = arr(i, 1)
      End If
    Next
    If z > 0 Then sh2.Cells(CellsOut, j).Resize(HowMany).Value = arr2
  Next
End Sub

The code works nicely, but what I wanted was to take all the written names (whether they are more or less than 5) and put them randomly in the other sheet without assigning HowMany
I mean the HowMany would be counting how many names are there on each column and put them randomly on the next sheet

 

[youbitto]

Also the empty cells are taken as a value, if possible I would like the code to skip them

 

[DanteAmor]

Also the empty cells are taken as a value, if possible I would like the code to skip them

I don't understand what you mean. The macro omits cells in empty, but they really must be empty, without spaces. Or explain to me with an example what you have and what you want to result.

 

[DanteAmor]

The code works nicely, but what I wanted was to take all the written names (whether they are more or less than 5) and put them randomly in the other sheet without assigning HowMany

Try this:

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

  Set sh1 = Worksheets("Inscrp")
  Set sh2 = Worksheets("Tirage")
  
  nrCol = sh2.Range("H4").Value
  CellsOut = 8
  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)).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(CellsOut, j).Resize(UBound(arr, 1)).Value = arr
    End If
  Next
End Sub

 

[youbitto]

Try this:

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

  Set sh1 = Worksheets("Inscrp")
  Set sh2 = Worksheets("Tirage")
 
  nrCol = sh2.Range("H4").Value
  CellsOut = 8
  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)).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(CellsOut, j).Resize(UBound(arr, 1)).Value = arr
    End If
  Next
End Sub

WOW very nice only a little thing
this is from the result sheet "Tirage"

as you can see it takes the empty cell as a name
This is from the names I wrote "Inscrp" sheet

 

[DanteAmor]

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