Random lucky draw (Name and prize with some conditions)

KK Wong

New Member
Joined
Dec 17, 2020
Messages
13
Office Version
  1. 365
Platform
  1. Windows
Hi there, I was assigned a task about an lucky draw event in our department as Xmas is coming. We have 42 employees and we have prepare 42 prizes as follows:

Cash PrizeTotal Number
$5002
$3003
$2005
$10032

We also have the name list of 42 employees.

The arrangement:
1. We may draw an employee name first, then draw the prize for that employee; or other way round, draw the prize first, then draw the employee, who will then get that prize
2. We want the last drawn (i.e. the 42nd round) to be $500 cash prize. That is, 41 prizes (including 1 of the $500 cash prizes) to be randomly drawn in the first 41 rounds and the last round must be $500 cash prize
3. Two bosses are in the name list. If in some round, they get $500 cash prize, there should be a button for redraw. Or, it should be programmed that they can't get the top prize.
4. After 42 rounds are done, a Msgbox should pop up saying it's the End of Event.

Below is the current codes I tried. You don't have to read it if you already know how to build the arrangement above... Thanks!!
-------------------------------------------------------------------------------------

My current codes:
- There are two worksheets. One is "LuckyDraw", used for drawing; another is "List", used for processing and storage of data.
- Worksheets("List").Range(A1,A42) is the name list.
- I have made 2 text boxes (ActiveX control) which are used for showing the name and prize, and they are linked to cell R1 and S1 respectively. I have also made 2 form control buttons, which are used for drawing the name and prize respectively.
- However, since I am still quite new to VBA, I could not build the perfect codes as the arrangement above. Refer to the codes below, I created a Sub. If I run this Sub, the 42 employees will be randomly drawn immediately and stored in Range(B1,B42)

VBA Code:
Sub Begin()

Dim lastRow As Long
Dim winners As New Collection
Dim drawCount As Long
Dim nextWinner As Long
Dim testResult As Variant

On Error Resume Next
MsgBox "Lucky Draw Begins! Good Luck!", , "Lucky Draw Begins"
Worksheets("List").Columns(2).ClearContents
lastRow = Worksheets("List").Cells(Rows.Count, 1).End(xlUp).Row
For drawCount = 1 To 42
    Do
        nextWinner = Int(Rnd() * lastRow) + 1
        Err.Clear
        testResult = winners(Worksheets("List").Cells(nextWinner, 1).Value)
    Loop Until Err.Number <> 0
    winners.Add nextWinner, Worksheets("List").Cells(nextWinner, 1).Value
    Worksheets("List").Cells(drawCount, 2).Value = Worksheets("List").Cells(nextWinner, 1).Value
Next drawCount

End Sub

Then, I manually input the 42 cash prizes in advance in Range(C1:C42) (that is, basically cheating because in this case the prizes are not really randomly drawn. In each round, the Name will be drawn first, then the prize. After the prize is drawn, Column D will write 1. Worksheets("List").Cells(10, 10) is formulated =SUM(D1:D42), so that the program can identify which round it is now.

Please refer to the codes below:
For Name:
Code:
Sub DrawName()

Dim NameRow As Long

On Error Resume Next

If Worksheets("List").Cells(10, 10) = 42 Then
MsgBox "End of draw. Thank you for your participation! Merry Christmas!!", , "This is the End"

Else: NameRow = Worksheets("List").Cells(10, 10) + 1
Worksheets("List").Cells(NameRow, 2).Copy Worksheets("LuckyDraw").Range("R1")
Worksheets("List").Cells(NameRow, 4) = "1"

End If

End Sub

For Prize:
Code:
Sub DrawGift()
Dim CouponRow As Long

On Error Resume Next

If Worksheets("List").Cells(10, 10) = 43 Then
MsgBox "End of draw. Thank you for your participation! Merry Christmas!!", , "This is the End"

Else: CouponRow = Worksheets("List").Cells(10, 10)
Worksheets("List").Cells(CouponRow, 3).Copy Worksheets("LuckyDraw").Range("S1")
MsgBox "Congratulations on winning " + Worksheets("List").Cells(CouponRow, 3).Value, , "Yeah!"

End If
Worksheets("LuckyDraw").Range("R1", "S1").ClearContents

End Sub

Problems of this code:
1. Have to draw name before prize; it could be boring
2. If the controller accidentally run the Name macro twice, it's messed up
3. If the controller accidentally run the prize first, it's messed up
4. Unable to eliminate the possibility of the two bosses getting the top prizes (if they are lucky enough)
 

Some videos you may like

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand

Eric W

MrExcel MVP
Joined
Aug 18, 2015
Messages
10,768
This is pretty basic, but should do what you want. Start with your sheet set up like this:

Book1 (version 1).xlsb
ABCDE
1NameMgmtPrizePrizes
2Amy500
3Bob500
4Cal300
5Deb300
6Ed300
7Fran200
8Gil200
9HankX200
10Iris200
11Jenny200
12Kishan100
13LatoyaX100
14Meg100
15Ned100
16Oscar100
17Pam100
18Quincy100
19Rae100
20Sam100
21Todd100
22Ursula100
23Val100
24Wes100
25Xena100
26Yancy100
27Zelda100
Sheet1


I only tested with 26 names, but you can just add names as far as you want, e.g. 42. Then enter this macro:

VBA Code:
Sub NextDraw()

    MyData = Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    
    nmr = 0     ' number of managers remaining
    nr = 0      ' number of people remaining
    npr = 0     ' number of non-500 prizes left
    For i = 1 To UBound(MyData)
        If MyData(i, 2) = "X" And MyData(i, 3) = "" Then
            nmr = nmr + 1
            m = i
        End If
        If MyData(i, 3) = "" Then
            nr = nr + 1
            r = i
        End If
        If MyData(i, 6) = "" And i > 2 Then npr = npr + 1
    Next i
    
    If nr = 1 Then
        Cells(r + 1, 3) = MyData(1, 5)
        Cells(2, 6) = MyData(r, 1)
        MsgBox ("The last person is " & MyData(r, 1) & " who wins " & MyData(1, 5) & "!")
        Exit Sub
    End If
    If nr = 0 Then Exit Sub
        
    a = MsgBox("Press 'Yes' if you want to pick a name, press 'No' if you want to pick an amount", vbYesNoCancel)
    If a = vbCancel Then
        MsgBox ("No draw")
        Exit Sub
    End If
    
    If a = vbYes Then
        
        If nmr > 0 And nmr = npr Then           ' # of managers = # of prizes left
            r = m                               ' so we have to pick a manager
            GoTo GotName:
        End If
        
        r = Int(Rnd() * UBound(MyData) + 1)     ' otherwise, pick a random name
        While MyData(r, 3) <> ""
            r = (r Mod UBound(MyData)) + 1
        Wend
        
GotName:
        MsgBox ("The next person is " & MyData(r, 1) & "!" & vbCrLf & vbCrLf & _
               "Press 'OK' to pick the prize:")
               
        p = Int(Rnd() * UBound(MyData) + 1)
        While p = 1 Or MyData(p, 6) <> "" Or (MyData(r, 2) = "X" And p = 2)
            p = (p Mod UBound(MyData)) + 1
        Wend
        
        Cells(r + 1, 3) = MyData(p, 5)
        Cells(p + 1, 6) = MyData(r, 1)
        MsgBox (MyData(r, 1) & " wins " & MyData(p, 5) & "!")
        Exit Sub
    End If
        
    p = Int(Rnd() * UBound(MyData) + 1)     ' pick a random remaining prize
    If nmr > 0 And npr = nmr Then p = UBound(MyData)
    While p = 1 Or MyData(p, 6) <> ""
        p = IIf(p = 1, UBound(MyData), p - 1)
    Wend
    
    MsgBox ("The prize is " & MyData(p, 5) & "!" & vbCrLf & vbCrLf & _
           "Press 'OK' to pick the person:")
    r = Int(Rnd() * UBound(MyData) + 1)
    If nmr > 0 And npr = nmr Then r = m
    While MyData(r, 3) <> ""
        r = (r Mod UBound(MyData)) + 1
    Wend
    
    Cells(r + 1, 3) = MyData(p, 5)
    Cells(p + 1, 6) = MyData(r, 1)
    MsgBox (MyData(r, 1) & " wins " & MyData(p, 5) & "!")
    
End Sub

You might want to put a button on your sheet that you can click to run it easier. Then just follow the prompts. It'll pick a name or amount, pause, then pick the matching value. It'll fill in columns C and F as the prizes are awarded. The 2 managers marked with X will never win the 500 prizes.

Let me know if this helps.
 

KK Wong

New Member
Joined
Dec 17, 2020
Messages
13
Office Version
  1. 365
Platform
  1. Windows
This is pretty basic, but should do what you want. Start with your sheet set up like this:

I only tested with 26 names, but you can just add names as far as you want, e.g. 42. Then enter this macro:

VBA Code:
Sub NextDraw()

    MyData = Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value
   
    nmr = 0     ' number of managers remaining
    nr = 0      ' number of people remaining
    npr = 0     ' number of non-500 prizes left
    For i = 1 To UBound(MyData)
        If MyData(i, 2) = "X" And MyData(i, 3) = "" Then
            nmr = nmr + 1
            m = i
        End If
        If MyData(i, 3) = "" Then
            nr = nr + 1
            r = i
        End If
        If MyData(i, 6) = "" And i > 2 Then npr = npr + 1
    Next i
   
    If nr = 1 Then
        Cells(r + 1, 3) = MyData(1, 5)
        Cells(2, 6) = MyData(r, 1)
        MsgBox ("The last person is " & MyData(r, 1) & " who wins " & MyData(1, 5) & "!")
        Exit Sub
    End If
    If nr = 0 Then Exit Sub
       
    a = MsgBox("Press 'Yes' if you want to pick a name, press 'No' if you want to pick an amount", vbYesNoCancel)
    If a = vbCancel Then
        MsgBox ("No draw")
        Exit Sub
    End If
   
    If a = vbYes Then
       
        If nmr > 0 And nmr = npr Then           ' # of managers = # of prizes left
            r = m                               ' so we have to pick a manager
            GoTo GotName:
        End If
       
        r = Int(Rnd() * UBound(MyData) + 1)     ' otherwise, pick a random name
        While MyData(r, 3) <> ""
            r = (r Mod UBound(MyData)) + 1
        Wend
       
GotName:
        MsgBox ("The next person is " & MyData(r, 1) & "!" & vbCrLf & vbCrLf & _
               "Press 'OK' to pick the prize:")
              
        p = Int(Rnd() * UBound(MyData) + 1)
        While p = 1 Or MyData(p, 6) <> "" Or (MyData(r, 2) = "X" And p = 2)
            p = (p Mod UBound(MyData)) + 1
        Wend
       
        Cells(r + 1, 3) = MyData(p, 5)
        Cells(p + 1, 6) = MyData(r, 1)
        MsgBox (MyData(r, 1) & " wins " & MyData(p, 5) & "!")
        Exit Sub
    End If
       
    p = Int(Rnd() * UBound(MyData) + 1)     ' pick a random remaining prize
    If nmr > 0 And npr = nmr Then p = UBound(MyData)
    While p = 1 Or MyData(p, 6) <> ""
        p = IIf(p = 1, UBound(MyData), p - 1)
    Wend
   
    MsgBox ("The prize is " & MyData(p, 5) & "!" & vbCrLf & vbCrLf & _
           "Press 'OK' to pick the person:")
    r = Int(Rnd() * UBound(MyData) + 1)
    If nmr > 0 And npr = nmr Then r = m
    While MyData(r, 3) <> ""
        r = (r Mod UBound(MyData)) + 1
    Wend
   
    Cells(r + 1, 3) = MyData(p, 5)
    Cells(p + 1, 6) = MyData(r, 1)
    MsgBox (MyData(r, 1) & " wins " & MyData(p, 5) & "!")
   
End Sub

You might want to put a button on your sheet that you can click to run it easier. Then just follow the prompts. It'll pick a name or amount, pause, then pick the matching value. It'll fill in columns C and F as the prizes are awarded. The 2 managers marked with X will never win the 500 prizes.

Let me know if this helps.

Hi Eric,

Thank you for your answer! It basically solves the problem. However, to make it more presentable, instead of using msgbox to draw the name/ prize, is it possible to keep the setting below?
Please check the picture attached:-
- 2 text boxes (ActiveX control) are used for showing the name and prize, and they are linked to cell R1 and S1 respectively (shown in the top left and right)
- 2 form control buttons are used for drawing the name and prize respectively (shown in the bottom left and right, each picture assigned one macro)

So for each round: when I hit the bottom left icon, the name will pop up on top left corner; subsequently when I hit the bottom right icon (i.e. the gift), the prize will show up. Vice versa - if I hit the gift icon first, the prize will show up, then when I hit name icon, the name will then show up. After 2 icons are clicked, Msgbox show up e.g. "Congratulations to Tina Lee on winning $100"

Slight adjustment is ok if the above is impossible to set up... But I do want to keep the 2 form control buttons and 2 text boxes (ActiveX control). Thanks!!!
 

Attachments

  • Demo-min.PNG
    Demo-min.PNG
    169.4 KB · Views: 4

Eric W

MrExcel MVP
Joined
Aug 18, 2015
Messages
10,768
I don't know the names of your worksheets, or your ActiveX controls, so you'll have to do some of the work. What I did was to split up the macro into 3 pieces. One you can link to your "Draw Name" button, one to attach to the "Draw Prize" button, and one to clear the current draw (more on that later).

You'll still want to set up a worksheet as follows:

Book1 (version 1).xlsb
ABCDEFGHI
1NameMgmtPrizePrizesNamePrize
2Amy500
3Bob500
4Cal300
5Deb300
6Ed300
7Fran200
8Gil200
9HankX200
10Iris200
11Jenny200
12Kishan100
13LatoyaX100
14Meg100
15Ned100
16Oscar100
17Pam100
18Quincy100
19Rae100
20Sam100
21Todd100
22Ursula100
23Val100
24Wes100
25Xena100
26Yancy100
27Zelda100
Sheet1


I added the H1:I2 area. Here are the macros:

VBA Code:
Sub ClearDraw()

    Set ds = Sheets("Sheet1")
    ds.Range("H2:I2").ClearContents
End Sub

Sub DrawName()

    Set ds = Sheets("Sheet1")
    If ds.Range("H2") <> "" Then Exit Sub
    
    MyData = ds.Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    
    nmr = 0     ' number of managers remaining
    nr = 0      ' number of people remaining
    npr = 0     ' number of non-500 prizes left
    For i = 1 To UBound(MyData)
        If MyData(i, 2) = "X" And MyData(i, 3) = "" Then
            nmr = nmr + 1
            m = i
        End If
        If MyData(i, 3) = "" Then
            nr = nr + 1
            r = i
        End If
        If MyData(i, 6) = "" And i > 2 Then npr = npr + 1
    Next i

    If nr = 0 Then Exit Sub
        
    If nmr > 0 And nmr = npr Then           ' # of managers = # of prizes left
        r = m                               ' so we have to pick a manager
        GoTo GotName:
    End If
        
    r = Int(Rnd() * UBound(MyData) + 1)     ' otherwise, pick a random name
    While MyData(r, 3) <> ""
        r = (r Mod UBound(MyData)) + 1
    Wend
    
GotName:
    ds.Range("H2").Value = MyData(r, 1)
    If ds.Range("I2").Value <> "" Then
        ds.Cells(r + 1, 3) = ds.Range("I2")
        For i = 1 To UBound(MyData)
            If MyData(i, 5) = ds.Range("I2") And MyData(i, 6) = "" Then
                ds.Cells(i + 1, 6) = MyData(r, 1)
                Exit For
            End If
        Next i
    End If
    
End Sub

Sub DrawPrize()

    Set ds = Sheets("Sheet1")
    If ds.Range("I2") <> "" Then Exit Sub
    
    MyData = ds.Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    
    nmr = 0     ' number of managers remaining
    nr = 0      ' number of people remaining
    npr = 0     ' number of non-500 prizes left
    For i = 1 To UBound(MyData)
        If MyData(i, 2) = "X" And MyData(i, 3) = "" Then
            nmr = nmr + 1
            m = i
        End If
        If MyData(i, 3) = "" Then
            nr = nr + 1
            r = i
        End If
        If MyData(i, 6) = "" And i > 2 Then npr = npr + 1
    Next i

    If nr = 0 Then Exit Sub
    If nr = 1 Then
        p = 1
        GoTo Last:
    End If
    
    p = Int(Rnd() * UBound(MyData) + 1)     ' pick a random remaining prize
    If nmr > 0 And npr = nmr Then p = UBound(MyData)
    While p = 1 Or MyData(p, 6) <> ""
        p = IIf(p = 1, UBound(MyData), p - 1)
    Wend
    
Last:
    ds.Range("I2").Value = MyData(p, 5)
    If ds.Range("H2").Value <> "" Then
        ds.Cells(p + 1, 6) = ds.Range("H2").Value
        For i = 1 To UBound(MyData)
            If MyData(i, 1) = ds.Range("H2") Then
                ds.Cells(i + 1, 3) = MyData(p, 5)
                Exit For
            End If
        Next i
    End If

End Sub

At the end of the DrawName procedure, you can see this line:

ds.Range("H2").Value = MyData(r, 1)

where I store the name. Add another line below it where you move the name to your R1 cell. In the DrawPrize Procedure, look for

ds.Range("I2").Value = MyData(p, 5)

and move the prize to your S1 cell too.

Once you've announced the winner, you need to clear the H2:I2 cells on the worksheet. The macros won't do anything until you do. (You also can't draw a name if you already have one, even if you haven't drawn a prize yet.) You have 2 options with the ClearDraw routine. You can clear the R1:S1 cells in that routine. Or at the end of both the DrawName/DrawPrize routines, check to see if both H2 and I2 are filled, and if so, clear them both right then. Then you'd clear your R1:S1 cells the way you do it now.


Also in both the DrawName/DrawPrize macros, look for this line:

If nr = 0 Then Exit Sub

about 18 lines in. You could change it to:

VBA Code:
    If nr = 0 Then
        MsgBox ("All names drawn!  Merry Christmas!")
        Exit Sub
    End If

if you like. Otherwise the macros just exit when you're done. I figure when you see the last 500 prize, you'll know that anyway.

Hope this helps! 🎄
 

KK Wong

New Member
Joined
Dec 17, 2020
Messages
13
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

I don't know the names of your worksheets, or your ActiveX controls, so you'll have to do some of the work. What I did was to split up the macro into 3 pieces. One you can link to your "Draw Name" button, one to attach to the "Draw Prize" button, and one to clear the current draw (more on that later).

You'll still want to set up a worksheet as follows:

Book1 (version 1).xlsb
ABCDEFGHI
1NameMgmtPrizePrizesNamePrize
2Amy500
3Bob500
4Cal300
5Deb300
6Ed300
7Fran200
8Gil200
9HankX200
10Iris200
11Jenny200
12Kishan100
13LatoyaX100
14Meg100
15Ned100
16Oscar100
17Pam100
18Quincy100
19Rae100
20Sam100
21Todd100
22Ursula100
23Val100
24Wes100
25Xena100
26Yancy100
27Zelda100
Sheet1


I added the H1:I2 area. Here are the macros:

VBA Code:
Sub ClearDraw()

    Set ds = Sheets("Sheet1")
    ds.Range("H2:I2").ClearContents
End Sub

Sub DrawName()

    Set ds = Sheets("Sheet1")
    If ds.Range("H2") <> "" Then Exit Sub
   
    MyData = ds.Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value
   
    nmr = 0     ' number of managers remaining
    nr = 0      ' number of people remaining
    npr = 0     ' number of non-500 prizes left
    For i = 1 To UBound(MyData)
        If MyData(i, 2) = "X" And MyData(i, 3) = "" Then
            nmr = nmr + 1
            m = i
        End If
        If MyData(i, 3) = "" Then
            nr = nr + 1
            r = i
        End If
        If MyData(i, 6) = "" And i > 2 Then npr = npr + 1
    Next i

    If nr = 0 Then Exit Sub
       
    If nmr > 0 And nmr = npr Then           ' # of managers = # of prizes left
        r = m                               ' so we have to pick a manager
        GoTo GotName:
    End If
       
    r = Int(Rnd() * UBound(MyData) + 1)     ' otherwise, pick a random name
    While MyData(r, 3) <> ""
        r = (r Mod UBound(MyData)) + 1
    Wend
   
GotName:
    ds.Range("H2").Value = MyData(r, 1)
    If ds.Range("I2").Value <> "" Then
        ds.Cells(r + 1, 3) = ds.Range("I2")
        For i = 1 To UBound(MyData)
            If MyData(i, 5) = ds.Range("I2") And MyData(i, 6) = "" Then
                ds.Cells(i + 1, 6) = MyData(r, 1)
                Exit For
            End If
        Next i
    End If
   
End Sub

Sub DrawPrize()

    Set ds = Sheets("Sheet1")
    If ds.Range("I2") <> "" Then Exit Sub
   
    MyData = ds.Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value
   
    nmr = 0     ' number of managers remaining
    nr = 0      ' number of people remaining
    npr = 0     ' number of non-500 prizes left
    For i = 1 To UBound(MyData)
        If MyData(i, 2) = "X" And MyData(i, 3) = "" Then
            nmr = nmr + 1
            m = i
        End If
        If MyData(i, 3) = "" Then
            nr = nr + 1
            r = i
        End If
        If MyData(i, 6) = "" And i > 2 Then npr = npr + 1
    Next i

    If nr = 0 Then Exit Sub
    If nr = 1 Then
        p = 1
        GoTo Last:
    End If
   
    p = Int(Rnd() * UBound(MyData) + 1)     ' pick a random remaining prize
    If nmr > 0 And npr = nmr Then p = UBound(MyData)
    While p = 1 Or MyData(p, 6) <> ""
        p = IIf(p = 1, UBound(MyData), p - 1)
    Wend
   
Last:
    ds.Range("I2").Value = MyData(p, 5)
    If ds.Range("H2").Value <> "" Then
        ds.Cells(p + 1, 6) = ds.Range("H2").Value
        For i = 1 To UBound(MyData)
            If MyData(i, 1) = ds.Range("H2") Then
                ds.Cells(i + 1, 3) = MyData(p, 5)
                Exit For
            End If
        Next i
    End If

End Sub

At the end of the DrawName procedure, you can see this line:

ds.Range("H2").Value = MyData(r, 1)

where I store the name. Add another line below it where you move the name to your R1 cell. In the DrawPrize Procedure, look for

ds.Range("I2").Value = MyData(p, 5)

and move the prize to your S1 cell too.

Once you've announced the winner, you need to clear the H2:I2 cells on the worksheet. The macros won't do anything until you do. (You also can't draw a name if you already have one, even if you haven't drawn a prize yet.) You have 2 options with the ClearDraw routine. You can clear the R1:S1 cells in that routine. Or at the end of both the DrawName/DrawPrize routines, check to see if both H2 and I2 are filled, and if so, clear them both right then. Then you'd clear your R1:S1 cells the way you do it now.


Also in both the DrawName/DrawPrize macros, look for this line:

If nr = 0 Then Exit Sub

about 18 lines in. You could change it to:

VBA Code:
    If nr = 0 Then
        MsgBox ("All names drawn!  Merry Christmas!")
        Exit Sub
    End If

if you like. Otherwise the macros just exit when you're done. I figure when you see the last 500 prize, you'll know that anyway.

Hope this helps! 🎄
Dear Eric,

Thank you for your new code! I decided to move it to the same worksheet and name it as Sheet1. I have tested it quite a few times with your new code.

I am not sure why but quite often 3 top prizes (i.e. $500) are drawn - 2 top prizes between the first 41 rounds (i.e. already 2 names in F2 and F3 respectively) and last one is still always $500. When this happens, on the 42nd round, when name and prize are drawn, the name of that employee will replace the name in F2 who previous won the $500 and recorded in F2. Thus, under Column F, only 41 names are shown after 42 rounds.

Moreover, on one occasion, a manager gets the top prizes. Could you please advise? Many thanks!!
 

Eric W

MrExcel MVP
Joined
Aug 18, 2015
Messages
10,768
Sorry about that! I tested the macros twice through, and didn't encounter those problems. Macros with random results can be hard to test because some problems don't show up quickly. Good job testing it. That said, I found the problem with both the issues you mentioned. Here's a fixed version of the macros:

VBA Code:
Sub ClearDraw()

    Set ds = Sheets("Sheet1")
    ds.Range("H2:I2").ClearContents
End Sub

Sub DrawName()

    Set ds = Sheets("Sheet1")
    If ds.Range("H2") <> "" Then Exit Sub
    
    MyData = ds.Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    
    nmr = 0     ' number of managers remaining
    nr = 0      ' number of people remaining
    npr = 0     ' number of non-500 prizes left
    For i = 1 To UBound(MyData)
        If MyData(i, 2) = "X" And MyData(i, 3) = "" Then
            nmr = nmr + 1
            m = i
        End If
        If MyData(i, 3) = "" Then
            nr = nr + 1
            r = i
        End If
        If MyData(i, 6) = "" And i > 2 Then npr = npr + 1
    Next i

    If nr = 0 Then Exit Sub
        
    If nmr > 0 And nmr = npr Then           ' # of managers = # of prizes left
        r = m                               ' so we have to pick a manager
        GoTo GotName:
    End If
        
    r = Int(Rnd() * UBound(MyData) + 1)     ' otherwise, pick a random name
    While MyData(r, 3) <> ""
        r = (r Mod UBound(MyData)) + 1
    Wend
    
GotName:
    ds.Range("H2").Value = MyData(r, 1)
    If ds.Range("I2").Value <> "" Then
        ds.Cells(r + 1, 3) = ds.Range("I2")
        For i = UBound(MyData) To 1 Step -1
            If MyData(i, 5) = ds.Range("I2") And MyData(i, 6) = "" Then
                ds.Cells(i + 1, 6) = MyData(r, 1)
                Exit For
            End If
        Next i
    End If
    
End Sub

Sub DrawPrize()

    Set ds = Sheets("Sheet1")
    If ds.Range("I2") <> "" Then Exit Sub
    
    MyData = ds.Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    
    nmr = 0     ' number of managers remaining
    nr = 0      ' number of people remaining
    npr = 0     ' number of non-500 prizes left
    mgr = False
    For i = 1 To UBound(MyData)
        If MyData(i, 2) = "X" And MyData(i, 3) = "" Then
            nmr = nmr + 1
            m = i
        End If
        If MyData(i, 1) = ds.Range("H2") And MyData(i, 2) = "X" Then mgr = True
        If MyData(i, 3) = "" Then
            nr = nr + 1
            r = i
        End If
        If MyData(i, 6) = "" And i > 2 Then npr = npr + 1
    Next i

    If nr = 0 Then
        MsgBox ("All names drawn!  Merry Christmas!")
        Exit Sub
    End If
    
    If nr = 1 Then
        p = 1
        GoTo Last:
    End If
    
    p = Int(Rnd() * UBound(MyData) + 1)     ' pick a random remaining prize
    If (nmr > 0 And npr = nmr) Or mgr Then p = UBound(MyData)
    While p = 1 Or MyData(p, 6) <> ""
        p = IIf(p = 1, UBound(MyData), p - 1)
    Wend
    
Last:
    ds.Range("I2").Value = MyData(p, 5)
    If ds.Range("H2").Value <> "" Then
        ds.Cells(p + 1, 6) = ds.Range("H2").Value
        For i = UBound(MyData) To 1 Step -1
            If MyData(i, 1) = ds.Range("H2") Then
                ds.Cells(i + 1, 3) = MyData(p, 5)
                Exit For
            End If
        Next i
    End If

End Sub
 

KK Wong

New Member
Joined
Dec 17, 2020
Messages
13
Office Version
  1. 365
Platform
  1. Windows
Sorry about that! I tested the macros twice through, and didn't encounter those problems. Macros with random results can be hard to test because some problems don't show up quickly. Good job testing it. That said, I found the problem with both the issues you mentioned. Here's a fixed version of the macros:

VBA Code:
Sub ClearDraw()

    Set ds = Sheets("Sheet1")
    ds.Range("H2:I2").ClearContents
End Sub

Sub DrawName()

    Set ds = Sheets("Sheet1")
    If ds.Range("H2") <> "" Then Exit Sub
   
    MyData = ds.Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value
   
    nmr = 0     ' number of managers remaining
    nr = 0      ' number of people remaining
    npr = 0     ' number of non-500 prizes left
    For i = 1 To UBound(MyData)
        If MyData(i, 2) = "X" And MyData(i, 3) = "" Then
            nmr = nmr + 1
            m = i
        End If
        If MyData(i, 3) = "" Then
            nr = nr + 1
            r = i
        End If
        If MyData(i, 6) = "" And i > 2 Then npr = npr + 1
    Next i

    If nr = 0 Then Exit Sub
       
    If nmr > 0 And nmr = npr Then           ' # of managers = # of prizes left
        r = m                               ' so we have to pick a manager
        GoTo GotName:
    End If
       
    r = Int(Rnd() * UBound(MyData) + 1)     ' otherwise, pick a random name
    While MyData(r, 3) <> ""
        r = (r Mod UBound(MyData)) + 1
    Wend
   
GotName:
    ds.Range("H2").Value = MyData(r, 1)
    If ds.Range("I2").Value <> "" Then
        ds.Cells(r + 1, 3) = ds.Range("I2")
        For i = UBound(MyData) To 1 Step -1
            If MyData(i, 5) = ds.Range("I2") And MyData(i, 6) = "" Then
                ds.Cells(i + 1, 6) = MyData(r, 1)
                Exit For
            End If
        Next i
    End If
   
End Sub

Sub DrawPrize()

    Set ds = Sheets("Sheet1")
    If ds.Range("I2") <> "" Then Exit Sub
   
    MyData = ds.Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value
   
    nmr = 0     ' number of managers remaining
    nr = 0      ' number of people remaining
    npr = 0     ' number of non-500 prizes left
    mgr = False
    For i = 1 To UBound(MyData)
        If MyData(i, 2) = "X" And MyData(i, 3) = "" Then
            nmr = nmr + 1
            m = i
        End If
        If MyData(i, 1) = ds.Range("H2") And MyData(i, 2) = "X" Then mgr = True
        If MyData(i, 3) = "" Then
            nr = nr + 1
            r = i
        End If
        If MyData(i, 6) = "" And i > 2 Then npr = npr + 1
    Next i

    If nr = 0 Then
        MsgBox ("All names drawn!  Merry Christmas!")
        Exit Sub
    End If
   
    If nr = 1 Then
        p = 1
        GoTo Last:
    End If
   
    p = Int(Rnd() * UBound(MyData) + 1)     ' pick a random remaining prize
    If (nmr > 0 And npr = nmr) Or mgr Then p = UBound(MyData)
    While p = 1 Or MyData(p, 6) <> ""
        p = IIf(p = 1, UBound(MyData), p - 1)
    Wend
   
Last:
    ds.Range("I2").Value = MyData(p, 5)
    If ds.Range("H2").Value <> "" Then
        ds.Cells(p + 1, 6) = ds.Range("H2").Value
        For i = UBound(MyData) To 1 Step -1
            If MyData(i, 1) = ds.Range("H2") Then
                ds.Cells(i + 1, 3) = MyData(p, 5)
                Exit For
            End If
        Next i
    End If

End Sub
It works perfectly now. Thank you for your advice. Wish you a merry Christmas too!
 

Watch MrExcel Video

Forum statistics

Threads
1,127,848
Messages
5,627,244
Members
416,233
Latest member
Riddlemethis

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
Top