Random Cell Selection

[Yevette]

I'm trying to set up a code to conduct a weekly drawing (like a lottery). My code is as follows:

'$500 GRAND PRIZE WINNER
Dim BegRowA As Integer
Dim EndRowA As Integer
EndRowA = Range("A65536").End(xlUp).Row
BegRowA = Int((EndRowA - 1 + 1) * Rnd + 1)
Range("A" & BegRowA).Select
Range(Selection, Selection.Offset(0, 1)).Copy
Sheets("WINNERS").Range("B4").PasteSpecial xlPasteValues
Sheets("RAFFLE").Select

'$300 GRAND PRIZE WINNER
Dim BegRowB As Integer
Dim EndRowB As Integer
EndRowB = Range("A65536").End(xlUp).Row
BegRowB = Int((EndRowB - 1 + 1) * Rnd + 1)
Range("A" & BegRowB).Select
Range(Selection, Selection.Offset(0, 1)).Copy
Sheets("WINNERS").Range("B5").PasteSpecial xlPasteValues

'$200 GRAND PRIZE WINNER
Dim BegRowC As Integer
Dim EndRowC As Integer
EndRowC = Range("A65536").End(xlUp).Row
BegRowC = Int((EndRowC - 1 + 1) * Rnd + 1)
Range("A" & BegRowC).Select
Range(Selection, Selection.Offset(0, 1)).Copy
Sheets("WINNERS").Range("B6").PasteSpecial xlPasteValues

Can anyone tell what the code would be to conduct a random selection (3 times) while restricting duplicate winners?

Thanks for your help!

 

[Richie(UK)]

Hi Yevette,

See if you can use this code for your purpose.

Sub Rand_Yevette()
    Dim wsWin As Worksheet
    Dim wsRaf As Worksheet
    Dim BegRow As Long
    Dim EndRow As Long
    Dim varRandNos As Variant
    
    With ThisWorkbook
        Set wsWin = .Worksheets("WINNERS")
        Set wsRaf = .Worksheets("RAFFLE")
    End With
    
    With wsWin
        EndRow = .Range("A65536").End(xlUp).Row
        BegRow = .Range("A1").Row
        varRandNos = TMOptRands(BegRow, EndRow, 3)
        'get 3 random numbers based on the row range
        wsRaf.Range("B4").Value = .Range("A" & varRandNos(1)).Value
        '$500 GRAND PRIZE WINNER
        wsRaf.Range("B5").Value = .Range("A" & varRandNos(2)).Value
        '$300 GRAND PRIZE WINNER
        wsRaf.Range("B6").Value = .Range("A" & varRandNos(3)).Value
        '$200 GRAND PRIZE WINNER
    End With
    
End Sub

Public Function TMOptRands(Bottom As Long, Top As Long, _
         Amount As Long) As Variant
'Tushar Mehta
    Dim i As Long, r As Long, temp As Long
    
    Application.Volatile
    
    ReDim iArr(Bottom To Top) As Long
    For i = Bottom To Top: iArr(i) = i: Next i
    For i = 0 To Amount - 1
        r = Int(Rnd() * (Top - Bottom + 1 - i)) _
            + (Bottom + i)
        temp = iArr(r)
        iArr(r) = iArr(Bottom + i)
        iArr(Bottom + i) = temp
     Next i
    ReDim Preserve iArr(Bottom To Bottom + Amount - 1)
    TMOptRands = iArr
End Function

Tushar has a good section on random selections on his site ( http://www.tushar-mehta.com/ )

HTH

 

[Richie(UK)]

Hi Richie!

Thank you so much for responding to my post! Unfortunately, the code did not work exactly right. It seemed to take the values from the WINNERS sheet and put them on the RAFFLE sheet in B4:B6:

B4: Winner 2 - $300 Prize [from WINNERS sheet A5]
B5: Winner 1 - $500 Prize [from WINNERS sheet A4]
B6: THIS WEEK'S RAFFLE WINNERS! [from WINNERS sheet A1]

For clarity, the RAFFLE sheet contains a list of employee numbers (Col A) and corresponding employee names (Col B). This is the list I want to execute the 3 random selections. The WINNERS sheet is where I want the 3 randomly selected numbers/names to go:

Col. A | Col. B | Col. C
Winner 1 - $500 Prize | 105067 | WinnerName1
Winner 2 - $300 Prize | 188676 | WinnerName2
Winner 3 - $200 Prize | 120577 | WinnerName3

I hope I've made things a little clearer and hope that you can help me adjust the code you provided to perform the task I need.

I went to Tushar's website, but failed to find anything to help me - not vba savvy....

Thanks again for your help Richie!

Hi Yevette,

Sorry - classic exam mistake, failed to read the question properly! :wink:

Try this (the function is unchanged):

Sub Rand_Yevette()
    Dim wsWin As Worksheet
    Dim wsRaf As Worksheet
    Dim BegRow As Long
    Dim EndRow As Long
    Dim varRandNos As Variant
    
    With ThisWorkbook
        Set wsWin = .Worksheets("WINNERS")
        Set wsRaf = .Worksheets("RAFFLE")
    End With
    
    With wsRaf
        EndRow = .Range("A65536").End(xlUp).Row
        BegRow = .Range("A1").Row
        varRandNos = TMOptRands(BegRow, EndRow, 3)
        'get 3 random numbers based on the row range
        wsWin.Range("B4").Resize(, 2).Value = .Range("A" & varRandNos(1)).Resize(, 2).Value
        '$500 GRAND PRIZE WINNER
        wsWin.Range("B5").Resize(, 2).Value = .Range("A" & varRandNos(2)).Resize(, 2).Value
        '$300 GRAND PRIZE WINNER
        wsWin.Range("B6").Resize(, 2).Value = .Range("A" & varRandNos(3)).Resize(, 2).Value
        '$200 GRAND PRIZE WINNER
    End With
    
End Sub

HTH

 

[Yevette]

Hi Richie!

Well, we're getting close! The code works, however, I still have the issue of getting duplicate winners. For example, I just ran the macro and got the following result:

Winner 1 - $500 Prize 105900 PAWLAK, DONNA
Winner 2 - $300 Prize 105900 PAWLAK, DONNA
Winner 3 - $200 Prize 106713 CORDOBA, PAUL

Is there a way to tweak the code so that it does not give me the same name more than once? I'm hoping to get this to work so that some poor soul in the company doesn't have to cut out 400 names and put them in a hat

Additional clarification: The RAFFLE sheet is comprised of the employee #/name (Cols A:B). However, the number of rows per employee depends on how many hours of overtime that employee worked. Donna Pawlak worked 5 hours OT, so she has 5 rows committed to her and so on. Would I be able to put some type of If, Then, Else statement into the mix? Do you think that would help? Thanks for your help and response - it is truly appreciated!

 

[Richie(UK)]

Hi Yevette,

Thats it, leave out the important bit of information why don't you? :wink:

OK, the first routine assumed that you had a unique range and that we were just trying to not to select the same one more than once. This time I've used the Advance Filter to give a unique range of items and used that as the criteria range. (You could just use an If Then construct to test for duplicates but this is a little more robust if you decide to change the number of selections at a later date).

Sub Rand_Yevette()
    Dim wsWin As Worksheet, wsRaf As Worksheet, wsAS As Worksheet
    Dim rngData As Range, rngUnique As Range, rngFill As Range, rngAC As Range
    Dim BegRow As Long, EndRow As Long, l As Long
    Dim varRandNos As Variant
    Const lSelections As Long = 3
    Const lRow As Long = 4, iCol As Integer = 2
    
    With ThisWorkbook
        Set wsWin = .Worksheets("WINNERS")
        Set wsRaf = .Worksheets("RAFFLE")
    End With
        
    Set wsAS = ActiveSheet
    Set rngAC = ActiveCell
    
    Application.ScreenUpdating = False
    
    With wsRaf
        .Activate
        .Rows(1).Insert
        .Range("A1").Value = "Dummy header"
        .Columns("H:I").Select
        Selection.Insert
        Set rngData = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
        rngData.AdvancedFilter _
            Action:=xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True
        .Rows(1).Delete
        'use the Advanced Filter to give unique info only starting from H1
        
        Set rngUnique = .Range("H1:H" & .Cells(Rows.Count, "H").End(xlUp).Row)
        Set rngFill = rngUnique.Offset(0, 1)
        'define the unique range and the one to its right
        
        With rngUnique.Cells(1, 1)
            .Offset(0, 1).Formula = _
                "=VLOOKUP(" & .Address(rowabsolute:=False, columnabsolute:=False) _
                & "," & rngData.Resize(, 2).Address & ",2,FALSE)"
            .Offset(0, 1).AutoFill Destination:=rngFill
        End With
        'lookup the names to match the numbers
        
        EndRow = .Range("H65536").End(xlUp).Row
        BegRow = .Range("H1").Row
        varRandNos = TMOptRands(BegRow, EndRow, lSelections)
        'get "lSelections" random numbers based on the row range
        
        With wsWin
            For l = 1 To lSelections
                .Cells(lRow + (l - 1), iCol).Resize(, 2).Value = _
                    wsRaf.Range("H" & varRandNos(l)).Resize(, 2).Value
            Next l
        End With
        'loop through the number of selections
        
        .Columns("H:I").Delete
        .Range("A1").Select
    End With
    
    wsAS.Activate
    rngAC.Select
    Application.ScreenUpdating = True

    
End Sub

Again, the function remains unchanged.

Hope its third time lucky

 

[Yevette]

Hi Richie,

Thanks for the code! I've been able to do a work-around until I heard from you so I'll look at your code and take from it what I can. On another note, can you help me with my latest posting? Subj: HELP! - Auto Calculation Mystery! Just thought I'd inquire, because I've about had it with this whole macro thing. Thanks for your help.

 

[tusharm]

Check the Excel | Tutorials | 'Random Selection' page of my web site