Random Selection Repetition in Rows

[peerogel]

I found the following code that randomly selects from a list and creates a random list into a column.

Sub Random_Names()
Dim NameColumn As Integer
Dim FirstNameRow As Integer
Dim NewColumn As Integer
Dim NumberOfNames As Integer
Dim lrow As Long
Dim StoredNames As String
Dim Counter As Integer
Dim Name As String
NameColumn = 1 'Change this if your names are not in column A
FirstNameRow = 2 'Change this if your first name does not start in row 2 (1 would be the column header)
NewColumn = 5 'Change this if you want to change the column of 10 names from column E to a different colulmn
NumberOfNames = 10 '10 Names in new list
lrow = Cells(Rows.Count, NameColumn).End(xlUp).Row
Counter = 2
StoredNames = ""
'Cells(1, NewColumn) = "Random Name List (" & NumberOfNames & ")"
'Range(Cells(2, NewColumn), Cells(2, 14)).ClearContents
Range(Cells(2, NewColumn), Cells(2, 14)).ClearContents

Do Until Cells(NumberOfNames + 1, NewColumn) <> ""
    Name = WorksheetFunction.Index(Range(Cells(FirstNameRow, NameColumn), Cells(lrow, NameColumn)), WorksheetFunction.RandBetween(1, lrow - FirstNameRow + 1))
    If InStr(Name, StoredNames) = 0 Then
        StoredNames = StoredNames & " " & Name
        Cells(Counter, NewColumn) = Name
        Counter = Counter + 1
    End If
Loop
End Sub

I modified to code to give me the list in the row instead, not sure if its good code but it works. Now, I'm trying to loop the code through several rows but I cant get it to work. I only keep managing to freeze excel. Thanks in advance for any help.

Sub Random_Names_Working1()
Dim NameColumn As Integer
Dim FirstNameRow As Integer
Dim NewColumn As Integer
Dim NumberOfNames As Integer
Dim RowStart As Integer
Dim lrow As Long
Dim StoredNames As String
Dim Counter As Integer
Dim Name As String
Dim x As Integer
Dim i As Integer

NameColumn = 1 'Change this if your names are not in column A
FirstNameRow = 2 'Change this if your first name does not start in row 2 (1 would be the column header)
NewColumn = 5 'Change this if you want to change the column of 10 names from column E to a different colulmn
NumberOfNames = 10 '10 Names in new list
' where the list begins
lrow = Cells(Rows.Count, NameColumn).End(xlUp).Row
Counter = 5
StoredNames = ""
'Cells(1, NewColumn) = "Random Name List (" & NumberOfNames & ")"
'Range(Cells(RowStart, NewColumn), Cells(NumberOfNames + 1, NewColumn)).ClearContents
      Application.ScreenUpdating = False
      ' Set numrows = number of rows of data.
      NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
      ' Establish "For" loop to loop "numrows" number of times.
      For x = 1 To NumRows
      RowStart = 2 + x
                    'Range(Cells(RowStart, NewColumn), Cells(RowStart, NumberOfNames + 4)).ClearContents
                    Do Until Cells(RowStart, NumberOfNames + 4) <> ""
                     Name = WorksheetFunction.Index(Range(Cells(FirstNameRow, NameColumn), Cells(lrow, NameColumn)), WorksheetFunction.RandBetween(1, lrow - FirstNameRow + 1))
                     If InStr(StoredNames, Name) = 0 Then
                    StoredNames = StoredNames & " " & Name
   
                    Cells(RowStart, Counter) = Name
                    Counter = Counter + 1
        End If
        Loop
      Next
        Next
      Application.ScreenUpdating = True

End Sub

 

[peerogel]

I think figured it out.

Sub Random_Names_Working1()
Dim NameColumn As Integer
Dim FirstNameRow As Integer
Dim NewColumn As Integer
Dim NumberOfNames As Integer
Dim RowStart As Integer
Dim lrow As Long
Dim StoredNames As String
Dim Counter As Integer
Dim Name As String
Dim x As Integer
Dim i As Integer

NameColumn = 1 'Change this if your names are not in column A
FirstNameRow = 2 'Change this if your first name does not start in row 2 (1 would be the column header)
NewColumn = 5 'Change this if you want to change the column of 10 names from column E to a different colulmn
NumberOfNames = 10 '10 Names in new list
' where the list begins
lrow = Cells(Rows.Count, NameColumn).End(xlUp).Row
Counter = 5
StoredNames = ""
'Cells(1, NewColumn) = "Random Name List (" & NumberOfNames & ")"
'Range(Cells(RowStart, NewColumn), Cells(NumberOfNames + 1, NewColumn)).ClearContents
      'Application.ScreenUpdating = False
      ' Set numrows = number of rows of data.
      NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
      ' Establish "For" loop to loop "numrows" number of times.
      For x = 1 To NumRows
      RowStart = 2 + x
                    'Range(Cells(RowStart, NewColumn), Cells(RowStart, NumberOfNames + 4)).ClearContents
                    Do Until Cells(RowStart, NumberOfNames + 4) <> ""
                     Name = WorksheetFunction.Index(Range(Cells(FirstNameRow, NameColumn), Cells(lrow, NameColumn)), WorksheetFunction.RandBetween(1, lrow - FirstNameRow + 1))
                     If InStr(StoredNames, Name) = 0 Then
                    StoredNames = StoredNames & " " & Name
   
                    Cells(RowStart, Counter) = Name
                    Counter = Counter + 1
        End If
        Loop
Counter = 5
NameColumn = 1
FirstNameRow = 2
StoredNames = ""
Next