LinkBack URL
About LinkBacks
Picking 2 names at random and not repeating them
Hi. I have a list of 51 names at the moment and I want it to pick 2 names art random and then do the same until all have been paired with someone else. I've found a macro that will pick random names but how do I get it to them pick another 25 names that are different to pair with the previous 25 names?
Macro used is
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 = Range("C1").Value
CellsOut = 2
ReDim Names(1 To HowMany) 'Set the array size to how many names required
NoOfNames = Application.CountA(Range("A:A")) - 1 ' Find how many names in the list
i = 1
Do While i <= HowMany
RandomNo:
RandomNumber = Application.RandBetween(2, NoOfNames + 1)
'Check to see if the name has already been picked
For ArI = LBound(Names) To UBound(Names)
If Names(ArI) = Cells(RandomNumber, 1).Value Then
GoTo RandomNo
End If
Next ArI
Names(i) = 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)
Cells(CellsOut, 2) = Names(ArI)
CellsOut = CellsOut + 1
Next ArI
Application.ScreenUpdating = True
End Sub
Any help is appreciated!
Register To Reply
Bookmarks