Results 1 to 7 of 7

Random Cell Selection

This is a discussion on Random Cell Selection within the Excel Questions forums, part of the Question Forums category; I'm trying to set up a code to conduct a weekly drawing (like a lottery). My code is as follows: ...

  1. #1
    Board Regular Yevette's Avatar
    Join Date
    Mar 2003
    Location
    Los Angeles, CA
    Posts
    328

    Default Random Cell Selection

    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!

  2. #2
    MrExcel MVP Richie(UK)'s Avatar
    Join Date
    May 2002
    Location
    UK
    Posts
    3,329

    Default Re: Random Cell Selection

    Hi Yevette,

    See if you can use this code for your purpose.
    Code:
    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

  3. #3
    MrExcel MVP Richie(UK)'s Avatar
    Join Date
    May 2002
    Location
    UK
    Posts
    3,329

    Default Re: Random Cell Selection

    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!

    Try this (the function is unchanged):
    Code:
    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
    Richie

  4. #4
    Board Regular Yevette's Avatar
    Join Date
    Mar 2003
    Location
    Los Angeles, CA
    Posts
    328

    Default Re: Random Cell Selection

    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!

  5. #5
    MrExcel MVP Richie(UK)'s Avatar
    Join Date
    May 2002
    Location
    UK
    Posts
    3,329

    Default Re: Random Cell Selection

    Hi Yevette,

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

    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).
    Code:
    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
    Richie

  6. #6
    Board Regular Yevette's Avatar
    Join Date
    Mar 2003
    Location
    Los Angeles, CA
    Posts
    328

    Default Re: Random Cell Selection

    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.

  7. #7
    MrExcel MVP tusharm's Avatar
    Join Date
    May 2002
    Posts
    10,900

    Default Re: Random Cell Selection

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

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  


DMCA.com