Help editing VBA code to pick 3 names randomly from a list of names

cjms85

New Member
Joined
Jul 7, 2009
Messages
19
Hi all,

I'm trying to write/adapt some VBA code that can pick 3 randomly pick names from a list. The must not pick the same name more than once.

I have a master list of names in column A. I have used another piece of code to pick a subset from this column (based on a separate criteria). This subset of names appears in column I. I would like to pick 3 names randomly from the subset of names in column I and output them to column J.

I have adapted the following code:

Code:
Option Explicit

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 = 3
CellsOut = 1


ReDim Names(1 To HowMany) 'Set the array size to how many names required
NoOfNames = Application.CountA(Range("I:I")) ' 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, 10) = Names(ArI)
    CellsOut = CellsOut + 1


Next ArI


Application.ScreenUpdating = True


End Sub

The problem I'm having is that it's currently picking up the master list of values in column A and not the subset from column I. Can anyone work out what I've missed in the code?

Many thanks,
Chris
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
You use
Code:
    …  Cells(RandomNumber, 1) …
Obviously this get data from column 1=A; replace 1 with 9=I (in two lines)

And your code could be simplified, both in checking for duplicates and in writing the results on the sheet:
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
'
HowMany = 3         '<<< Your limit
'
ReDim Names(1 To HowMany) 'Set the array size to how many names required
NoOfNames = Application.CountA(Range("I:I")) ' Find how many names in the list
If HowMany > NoOfNames Then Exit Sub
i = 1
Do While i <= HowMany
    RandomNumber = Application.RandBetween(2, NoOfNames + 1)
    If IsError(Application.Match(Cells(RandomNumber, 9), Names, False)) Then
        Names(i) = Cells(RandomNumber, 9)
        i = i + 1
    End If
    DoEvents
Loop
'Dump Names:
Cells(1, 10).Resize(HowMany, 1) = Application.WorksheetFunction.Transpose(Names)
End Sub
Bye
 
Upvote 0
Hi Anthony47,

Thanks for updating/adapting the code. I'm still having a slight problem though. When I run the code you've changed, instead of always giving me 3 randomly selected names from a list, it gives me between 1 and 3 randomly selected names from a list. I would like it always to give me 3 names, but just randomly selected.

Here's a link to my file with the code.
https://drive.google.com/file/d/1T30tiRrszaLO3gp3lsTquVvAXNOxezFF/view?usp=sharing

Cheers,
Chris
 
Upvote 0
If you are willing to consider a different approach, the following macro should do what you are attempting to do...
Code:
Sub GetRandomNamesFromColumnI()
  Dim HowMany As Long, Cnt As Long, RandomIndex As Long
  Dim Tmp As Variant, Nmes As Variant
  HowMany = 1
  Nmes = Range("I1", Cells(Rows.Count, "I").End(xlUp))
  Randomize
  For Cnt = 1 To UBound(Nmes)
    RandomIndex = Int(Cnt * Rnd + 1)
    Tmp = Nmes(RandomIndex, 1)
    Nmes(RandomIndex, 1) = Nmes(Cnt, 1)
    Nmes(Cnt, 1) = Tmp
  Next
  Range("J1").Resize(HowMany) = Nmes
End Sub
 
Upvote 0
Code:
RandomNumber = Application.RandBetween(2, NoOfNames + 1)
This portion of your code suggested to me that your list in column I starts on row 2, with row 1 empty.

If your list starts from Row 1 than you need to modify that line:
Code:
RandomNumber = Application.RandBetween(1, NoOfNames)
If your list has a header (not a name) on row 1:
Code:
RandomNumber = Application.RandBetween(2, NoOfNames)

@Rick, smart solution.

Bye
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,214
Messages
6,170,774
Members
452,353
Latest member
strainu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top