'Weighted' random name picker

M

ma0ffst08

Board Regular
Joined
Apr 22, 2008
Messages
128
Office Version
  1. 2019
Platform
  1. Windows
Hello,

I have a spreadsheet with a list of names in column A (Cell A1 has the title "Names", and names are in cell A2 onwards).
This list can change in length, and people's names sometimes have multiple entries.
Cell H1 has the word "Winners"

What I would like please is a macro that will:

1) Prompt the user to define how many names should be picked, and a cancel/do nothing option
2) Pick a random name from the list in column A
3) Paste this name into cell H2. If a fancy pop up with the name in colour and in bold can be shown at this point (with a continue button), then that would be awesome, but not essential, although this may not be possible in Excel
4) Once this name has been picked, all instances of this name in column A are highlighted in red
5) Steps 2-4 are repeated for as many times as specified in step 1, however - if a name is picked, then it cannot then be picked again in any subsequent iterations. The second name picked would go into cell H3, then H4 etc.
6) Once all iterations have been completed, a message box pops up saying "congratulations to all our winners"
7) Once all iterations have completed, a subsequent press off the button starts again from step 1 and column H (H2 downwards) is cleared.

I hope this is simple for someone with a much vaster knowledge of macros - many many thanks indeed!
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
Hello @ma0ffst08, I hope you are well.

I understand you asked for a macro. But you can also do it with the excel functionality.
Do the following.
  • In column K put the unique names.
  • In cell L2 and down the Rand function.
  • In cell H2 and down the number of names you want the following Index formula.
  • And finally, some conditional formatting in column A to highlight the winning names.

name winners.xlsx
ABCDEFGHIJKL
1NamesWinnersUnique names
2Ana1AnaAna0.98264759
3Carlos2LauraCarlos0.57026744
4Daniel3CarlosDaniel0.80940401
5GloriaGloria0.55257197
6LauraLaura0.0405772
7MaríaMaría0.63863065
8PedroPedro0.57059328
9RaúlRaúl0.37688469
10SoniaSonia0.16662173
11Ana
12Carlos
13Daniel
14Gloria
15Laura
16María
17Pedro
18Raúl
19Sonia
20Ana
21Carlos
22Daniel
23Gloria
24Laura
25María
26Pedro
27Raúl
28Sonia
Hoja1
Cell Formulas
RangeFormula
H2:H4H2=INDEX($K$2:$K$10,RANK.EQ(L2,$L$2:$L$10))
L2:L10L2=RAND()
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A2:A28Expression=COUNTIF($H:$H,$A2)textNO



----- --
Comment if it works for you.
Sincerely
Dante Amor
----- --
 
Upvote 0
try this code. run: PickWinners

Code: 
Public Const Q = """"
Public Const giColWin = 8   'col.H
Public gcolNames As Collection
Public giPickCt As Integer
Public rng As Range

Public Sub PickWinners()
Dim vRet
Dim i As Integer

'start over
 vRet = InputBox("How many winners?", "Winners to choose")
If vRet = "" Or vRet <= 0 Then Exit Sub
 
giPickCt = vRet

LoadNames
For i = 1 To giPickCt
   Pick1Rando
   If gcolNames.Count = 0 Then GoTo endit
Next

endit:
MsgBox "Game Over"
End Sub


Private Sub LoadNames()
Dim sName As String
    
On Error Resume Next

If gcolNames Is Nothing Or gcolNames.Count = 0 Then
   'If MsgBox("Begin New Game", vbQuestion + vbYesNo, "Confirm") = vbNo Then End
   
   ClearResults
   
   Set gcolNames = New Collection
   ''iPicks = 0
   
    Range("A2").Select
    While ActiveCell.Value <> ""
       sName = ActiveCell.Value
       gcolNames.Add sName, sName
       
       ActiveCell.Offset(1, 0).Select 'next row
    Wend
    
      'start of winners list
    Cells(2, 8).Select
Else
   'list already loaded
End If
End Sub


Private Sub Pick1Rando()
Dim iRows As Long, r As Long
Dim iRnd As Integer
Dim vName

On Error Resume Next

    'pick random
iRnd = Int((gcolNames.Count * Rnd) + 1)

  'post winner
'iPicks = iPicks + 1
vName = gcolNames(iRnd)


ActiveCell.Offset(0, 0).Value = vName

 'bookmark our spot
Set rng = ActiveCell
Redline vName
rng.Select

ActiveCell.Offset(1, 0).Select   'next row

'remove winner from list
gcolNames.Remove iRnd
End Sub

Private Sub ClearResults()
Dim vLtr
vLtr = cvtColNum2Ltr(giColWin)
Columns(vLtr & ":" & vLtr).ClearContents
Range(vLtr & "1").Value = "Winners"
ClearRedline
End Sub

Private Sub Redline(ByVal pvName)

    Columns("A:A").Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=" & Q & pvName & Q
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
End Sub

Private Sub ClearRedline()
    Cells.FormatConditions.Delete
    Range("A1").Select
End Sub

Private Function cvtColNum2Ltr(ByVal pvColNum)
Dim vRet
vRet = Mid(Cells(1, pvColNum).Address, 2)
cvtColNum2Ltr = Left(vRet, InStr(vRet, "$") - 1)
End Function
 
Upvote 0
DanteAmor said:
Hello @ma0ffst08, I hope you are well.

I understand you asked for a macro. But you can also do it with the excel functionality.
Do the following.
  • In column K put the unique names.
  • In cell L2 and down the Rand function.
  • In cell H2 and down the number of names you want the following Index formula.
  • And finally, some conditional formatting in column A to highlight the winning names.

name winners.xlsx
ABCDEFGHIJKL
1NamesWinnersUnique names
2Ana1AnaAna0.98264759
3Carlos2LauraCarlos0.57026744
4Daniel3CarlosDaniel0.80940401
5GloriaGloria0.55257197
6LauraLaura0.0405772
7MaríaMaría0.63863065
8PedroPedro0.57059328
9RaúlRaúl0.37688469
10SoniaSonia0.16662173
11Ana
12Carlos
13Daniel
14Gloria
15Laura
16María
17Pedro
18Raúl
19Sonia
20Ana
21Carlos
22Daniel
23Gloria
24Laura
25María
26Pedro
27Raúl
28Sonia
Hoja1
Cell Formulas
RangeFormula
H2:H4H2=INDEX($K$2:$K$10,RANK.EQ(L2,$L$2:$L$10))
L2:L10L2=RAND()
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A2:A28Expression=COUNTIF($H:$H,$A2)textNO



----- --
Comment if it works for you.
Sincerely
Dante Amor
----- --
Click to expand...
Thank you. Unfortunately it needs to be a macro/vba as it's for a prize draw
 
Upvote 0
ranman256 said:
try this code. run: PickWinners

Code: 
Public Const Q = """"
Public Const giColWin = 8   'col.H
Public gcolNames As Collection
Public giPickCt As Integer
Public rng As Range

Public Sub PickWinners()
Dim vRet
Dim i As Integer

'start over
 vRet = InputBox("How many winners?", "Winners to choose")
If vRet = "" Or vRet <= 0 Then Exit Sub
 
giPickCt = vRet

LoadNames
For i = 1 To giPickCt
   Pick1Rando
   If gcolNames.Count = 0 Then GoTo endit
Next

endit:
MsgBox "Game Over"
End Sub


Private Sub LoadNames()
Dim sName As String
   
On Error Resume Next

If gcolNames Is Nothing Or gcolNames.Count = 0 Then
   'If MsgBox("Begin New Game", vbQuestion + vbYesNo, "Confirm") = vbNo Then End
  
   ClearResults
  
   Set gcolNames = New Collection
   ''iPicks = 0
  
    Range("A2").Select
    While ActiveCell.Value <> ""
       sName = ActiveCell.Value
       gcolNames.Add sName, sName
      
       ActiveCell.Offset(1, 0).Select 'next row
    Wend
   
      'start of winners list
    Cells(2, 8).Select
Else
   'list already loaded
End If
End Sub


Private Sub Pick1Rando()
Dim iRows As Long, r As Long
Dim iRnd As Integer
Dim vName

On Error Resume Next

    'pick random
iRnd = Int((gcolNames.Count * Rnd) + 1)

  'post winner
'iPicks = iPicks + 1
vName = gcolNames(iRnd)


ActiveCell.Offset(0, 0).Value = vName

 'bookmark our spot
Set rng = ActiveCell
Redline vName
rng.Select

ActiveCell.Offset(1, 0).Select   'next row

'remove winner from list
gcolNames.Remove iRnd
End Sub

Private Sub ClearResults()
Dim vLtr
vLtr = cvtColNum2Ltr(giColWin)
Columns(vLtr & ":" & vLtr).ClearContents
Range(vLtr & "1").Value = "Winners"
ClearRedline
End Sub

Private Sub Redline(ByVal pvName)

    Columns("A:A").Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=" & Q & pvName & Q
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
End Sub

Private Sub ClearRedline()
    Cells.FormatConditions.Delete
    Range("A1").Select
End Sub

Private Function cvtColNum2Ltr(ByVal pvColNum)
Dim vRet
vRet = Mid(Cells(1, pvColNum).Address, 2)
cvtColNum2Ltr = Left(vRet, InStr(vRet, "$") - 1)
End Function
Click to expand...
Hi, thank you for looking into this.

It is very nearly there, I have tried it and there's just a couple of small tweaks if you please have time?

Step 1 above (asking how many winners) please can this be removed?
When you run PickWinners, on each click, can the next name be drawn? When there are no more names to pick, it says game over

Separate macro to clear winners in column H and unhighlight names in column A.

Thank you
 
Upvote 0
ma0ffst08 said:
it needs to be a macro
Click to expand...
Then, try this:

VBA Code: 
Sub winners()
  Dim a As Variant, b As Variant, arr As Variant, iRow As Variant
  Dim dic As Object
  Dim nNames&, i&, j&, k&, m&, x&, y&, z&
 
  With Range("A2", Range("A" & Rows.Count).End(3))
    .Interior.Color = xlNone
    a = .Value
    Range("H2:H" & Rows.Count).ClearContents
  End With
 
  ReDim b(1 To UBound(a), 1 To 1)
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      k = k + 1
      b(k, 1) = a(i, 1)
    End If
    dic(a(i, 1)) = dic(a(i, 1)) & i + 1 & ","
  Next
 
  nNames = Application.InputBox("How many names should be picked", "Random name picker", Type:=1)
  If nNames = 0 Then
    MsgBox "Cancelled"
    Exit Sub
  End If
  If nNames > dic.Count Then
    MsgBox "The requested number of names is greater than the number of available names"
    Exit Sub
  End If
 
  Randomize
  j = 2
  arr = Evaluate("ROW(1:" & dic.Count & ")")      'total records
  For z = 1 To nNames                             'how many do i want
    x = Int(Rnd * k + z)
    y = arr(z, 1)
    arr(z, 1) = arr(x, 1)
    arr(x, 1) = y
    k = k - 1
    m = arr(z, 1)                         'random number
  
    Range("H" & j).Value = b(m, 1)
    For Each iRow In Split(dic(b(m, 1)), ",")
      If iRow <> "" Then Range("A" & iRow).Interior.Color = vbRed
    Next
 
    MsgBox "Name: " & b(m, 1), vbOKOnly
    j = j + 1
  Next
 
  MsgBox "Congratulations to all our winners"
End Sub

-----------------------------------------------

ma0ffst08 said:
Step 1 above (asking how many winners) please can this be removed?
When you run PickWinners, on each click, can the next name be drawn? When there are no more names to pick, it says game over
Click to expand...

You changed some rules from your original request, then try this:
VBA Code: 
Sub winners_v2()
  Dim a As Variant, b As Variant, arr As Variant, iRow As Variant
  Dim dic As Object
  Dim nNames&, i&, j&, k&, m&, x&, y&, z&
 
  With Range("A2", Range("A" & Rows.Count).End(3))
    .Interior.Color = xlNone
    a = .Value
    Range("H2:H" & Rows.Count).ClearContents
  End With
 
  ReDim b(1 To UBound(a), 1 To 1)
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      k = k + 1
      b(k, 1) = a(i, 1)
    End If
    dic(a(i, 1)) = dic(a(i, 1)) & i + 1 & ","
  Next
 
  Randomize
  j = 2
  arr = Evaluate("ROW(1:" & k & ")")      'total records
  For z = 1 To k                             'how many do i want
    x = Int(Rnd * k + z)
    y = arr(z, 1)
    arr(z, 1) = arr(x, 1)
    arr(x, 1) = y
    k = k - 1
    m = arr(z, 1)                         'random number
   
    Range("H" & j).Value = b(m, 1)
    For Each iRow In Split(dic(b(m, 1)), ",")
      If iRow <> "" Then Range("A" & iRow).Interior.Color = vbRed
    Next
 
    MsgBox "Name: " & b(m, 1), vbOKOnly
    j = j + 1
  Next
 
  MsgBox "game over"
End Sub

I hope one of the 2 macros works for you.

Regards
Dante Amor
🫡
 
Last edited:
Upvote 0
Solution
DanteAmor said:
Then, try this:

VBA Code: 
Sub winners()
  Dim a As Variant, b As Variant, arr As Variant, iRow As Variant
  Dim dic As Object
  Dim nNames&, i&, j&, k&, m&, x&, y&, z&
 
  With Range("A2", Range("A" & Rows.Count).End(3))
    .Interior.Color = xlNone
    a = .Value
    Range("H2:H" & Rows.Count).ClearContents
  End With
 
  ReDim b(1 To UBound(a), 1 To 1)
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      k = k + 1
      b(k, 1) = a(i, 1)
    End If
    dic(a(i, 1)) = dic(a(i, 1)) & i + 1 & ","
  Next
 
  nNames = Application.InputBox("How many names should be picked", "Random name picker", Type:=1)
  If nNames = 0 Then
    MsgBox "Cancelled"
    Exit Sub
  End If
  If nNames > dic.Count Then
    MsgBox "The requested number of names is greater than the number of available names"
    Exit Sub
  End If
 
  Randomize
  j = 2
  arr = Evaluate("ROW(1:" & dic.Count & ")")      'total records
  For z = 1 To nNames                             'how many do i want
    x = Int(Rnd * k + z)
    y = arr(z, 1)
    arr(z, 1) = arr(x, 1)
    arr(x, 1) = y
    k = k - 1
    m = arr(z, 1)                         'random number
 
    Range("H" & j).Value = b(m, 1)
    For Each iRow In Split(dic(b(m, 1)), ",")
      If iRow <> "" Then Range("A" & iRow).Interior.Color = vbRed
    Next
 
    MsgBox "Name: " & b(m, 1), vbOKOnly
    j = j + 1
  Next
 
  MsgBox "Congratulations to all our winners"
End Sub

-----------------------------------------------



You changed some rules from your original request, then try this:
VBA Code: 
Sub winners_v2()
  Dim a As Variant, b As Variant, arr As Variant, iRow As Variant
  Dim dic As Object
  Dim nNames&, i&, j&, k&, m&, x&, y&, z&
 
  With Range("A2", Range("A" & Rows.Count).End(3))
    .Interior.Color = xlNone
    a = .Value
    Range("H2:H" & Rows.Count).ClearContents
  End With
 
  ReDim b(1 To UBound(a), 1 To 1)
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      k = k + 1
      b(k, 1) = a(i, 1)
    End If
    dic(a(i, 1)) = dic(a(i, 1)) & i + 1 & ","
  Next
 
  Randomize
  j = 2
  arr = Evaluate("ROW(1:" & k & ")")      'total records
  For z = 1 To k                             'how many do i want
    x = Int(Rnd * k + z)
    y = arr(z, 1)
    arr(z, 1) = arr(x, 1)
    arr(x, 1) = y
    k = k - 1
    m = arr(z, 1)                         'random number
  
    Range("H" & j).Value = b(m, 1)
    For Each iRow In Split(dic(b(m, 1)), ",")
      If iRow <> "" Then Range("A" & iRow).Interior.Color = vbRed
    Next
 
    MsgBox "Name: " & b(m, 1), vbOKOnly
    j = j + 1
  Next
 
  MsgBox "game over"
End Sub

I hope one of the 2 macros works for you.

Regards
Dante Amor
🫡
Click to expand...
Thank you so much! This is perfect!
 
Upvote 0
ma0ffst08 said:
Thank you so much! This is perfect!
Click to expand...
Hi Dante, I was just wondering, is there any way to ensure the message box does not appear right in the middle of the screen? Maybe in the top right corner if possible, or in the gap in cells C9:F16? No problem if not possible. Thank you
 

Attachments

  • Lotto.jpg
    Lotto.jpg
    201.1 KB · Views: 24
Upvote 0
There are some codes to position the msgbox on the screen, for example:

www.mrexcel.com

how to change the location of Msg box

Hello guys, I have created a vba code in excel. which shows a msgbox a particular sheets is active ( that is when u click sheet2 a message box appears) with some message.That message box appears on the middle of the sheet i wanted that to be appeared on top the the page or somewhere left top...
www.mrexcel.com www.mrexcel.com
www.mrexcel.com

vba code to possition a message box?

Hi everyone, does anyone know if its possible to position a message box where you want it on the screen with vba code? at the moment my message box pops up in the middle of the screen? this is not ideal as I'd like it to the right. I'm happy to play about with the numbers to get it into...
www.mrexcel.com www.mrexcel.com

Another option is to create a shape and position it on the screen after pressing that shape, delete it.

Another option is to create a userform. You show it instead of the msgbox and close it after pressing a button.

:giggle:
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Combo box help
Replies
7
Views
237
Micron
M
E
  • Question Question
Random name draw for multiple weighted entries with no duplicates
Replies
1
Views
632
Cubist
Cubist
A
  • Question Question
VBA How to auto populate number randomly with criteria that each person must be picked once
2
Replies
12
Views
519
AmirFirdaus9509
A
M
  • Solved
Changing the position of a message box
Replies
1
Views
505
6StringJazzer
6StringJazzer
S
  • Question Question
Creating a random sequence of items from a weighted list with no duplicates
Replies
6
Views
181
shg
shg

Forum statistics

Threads
1,223,711
Messages
6,174,029
Members
452,542
Latest member
Bricklin

Share this page

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