Random lucky draw (Name and prize with some conditions)

[KK Wong]

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 Prize	Total Number
$500	2
$300	3
$200	5
$100	32

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)

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:

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:

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)

 

[Eric W]

This is pretty basic, but should do what you want. Start with your sheet set up like this:

Book1 (version 1).xlsb
	A	B	C	D	E
1	Name	Mgmt	Prize		Prizes
2	Amy				500
3	Bob				500
4	Cal				300
5	Deb				300
6	Ed				300
7	Fran				200
8	Gil				200
9	Hank	X			200
10	Iris				200
11	Jenny				200
12	Kishan				100
13	Latoya	X			100
14	Meg				100
15	Ned				100
16	Oscar				100
17	Pam				100
18	Quincy				100
19	Rae				100
20	Sam				100
21	Todd				100
22	Ursula				100
23	Val				100
24	Wes				100
25	Xena				100
26	Yancy				100
27	Zelda				100
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:

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]

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:

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!!!

 

[Eric W]

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
	A	B	C	D	E	F	G	H	I
1	Name	Mgmt	Prize		Prizes			Name	Prize
2	Amy				500
3	Bob				500
4	Cal				300
5	Deb				300
6	Ed				300
7	Fran				200
8	Gil				200
9	Hank	X			200
10	Iris				200
11	Jenny				200
12	Kishan				100
13	Latoya	X			100
14	Meg				100
15	Ned				100
16	Oscar				100
17	Pam				100
18	Quincy				100
19	Rae				100
20	Sam				100
21	Todd				100
22	Ursula				100
23	Val				100
24	Wes				100
25	Xena				100
26	Yancy				100
27	Zelda				100
Sheet1

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

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:

    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]

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
	A	B	C	D	E	F	G	H	I
1	Name	Mgmt	Prize		Prizes			Name	Prize
2	Amy				500
3	Bob				500
4	Cal				300
5	Deb				300
6	Ed				300
7	Fran				200
8	Gil				200
9	Hank	X			200
10	Iris				200
11	Jenny				200
12	Kishan				100
13	Latoya	X			100
14	Meg				100
15	Ned				100
16	Oscar				100
17	Pam				100
18	Quincy				100
19	Rae				100
20	Sam				100
21	Todd				100
22	Ursula				100
23	Val				100
24	Wes				100
25	Xena				100
26	Yancy				100
27	Zelda				100
Sheet1

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

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:

    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]

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:

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]

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:

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!