Weighted Random Number Generator Code Needed

Ben,

Here is commented code that should perform as desired:

Sub tgr()
    
    'Declare variables
    Dim ws As Worksheet             'Used to access the sheet 'Entry Summary'
    Dim rngEntries As Range         'Used to store the range of entries of participants
    Dim EntryCell As Range          'Used to loop through rngEntries
    Dim rngFindWinner As Range      'Used to find winners
    Dim lCalc As XlCalculation      'Used to store the current calculation state
    Dim arrParticipants() As String 'Used to store the weighted participant entries for finding winners
    Dim strFirst As String          'Used to prevent duplicates when finding winners
    Dim strWinners As String        'Used to build the winners list
    Dim ParticipantIndex As Long    'Used to build arrParticipants
    Dim lNumParticipants As Long    'Used to determine how many participants there are
    Dim i As Long                   'Generic counter variable
    
    'Assign variable ws and get the number of participants
    Set ws = Sheets("Entry Summary")
    lNumParticipants = ws.Range("K4").Value
    
    If lNumParticipants = 0 Then Exit Sub   'no participants
    
    'Disable events, alerts, and screenupdating, set calculation to manual
    'This prevents "screen flickering" and allows the code to run faster
    With Application
        lCalc = .Calculation                'Store the current calculation state
        .Calculation = xlCalculationManual  'Set to manual calculation
        .EnableEvents = False               'Disable events
        .DisplayAlerts = False              'Disable alerts
        .ScreenUpdating = False             'Disable screenupdating
    End With
    
    'Assume code will fail and provide error handler
    On Error GoTo CleanExit
    
    'Assign variable rngEntries and dimension arrParticipants to the correct size
    Set rngEntries = ws.Range("E23").Resize(lNumParticipants)
    ReDim arrParticipants(1 To WorksheetFunction.Sum(rngEntries))
    
    'Loop through each cell in rngEntries
    For Each EntryCell In rngEntries.Cells
        'Add the participant for each entry (2 automatic + any correctly answered questions)
        For i = 1 To EntryCell.Value
            ParticipantIndex = ParticipantIndex + 1
            arrParticipants(ParticipantIndex) = ws.Cells(EntryCell.Row, "B").Text
        Next i
    Next EntryCell
    
    'Use a new sheet that will not be seen
    'This sheet is used to find the winners
    With Sheets.Add
        'Put arrparticipants, a randomization formula, and a formula to find unique entries in this new sheet
        .Range("A1").Resize(ParticipantIndex).Value = Application.Transpose(arrParticipants)
        .Range("B1").Resize(ParticipantIndex).Formula = "=Rand()"
        .Range("C1").Resize(ParticipantIndex).Formula = "=Countif(A$1:A1,A1)"
        
        'Randomize the weighted participants list
        Randomize
        .Calculate
        .UsedRange.Sort .Range("B1").Resize(ParticipantIndex), xlAscending, Header:=xlNo
        
        'Find the first three unique entries and build the winners list
        Set rngFindWinner = .Columns("C").Find(1, .Range("C" & Rows.Count), xlValues, xlWhole)
        If Not rngFindWinner Is Nothing Then
            i = 0
            strFirst = rngFindWinner.Address
            Do
                strWinners = strWinners & Chr(10) & .Cells(rngFindWinner.Row, "A").Text
                i = i + 1
                If i = 3 Then Exit Do
                Set rngFindWinner = .Columns("C").Find(1, rngFindWinner, xlValues, xlWhole)
            Loop While rngFindWinner.Address <> strFirst
        End If
        
        'Delete the temp sheet now that the winners list has been completed
        .Delete
    End With
    
    'Output the winners
    ws.Range("I7").Value = Split(strWinners, Chr(10))(1)
    ws.Range("I10").Value = Split(strWinners, Chr(10))(2)
    ws.Range("I13").Value = Split(strWinners, Chr(10))(3)
    
'Error handler
'The code will exit here even if there wasn't an error
CleanExit:
    
    'Re-enable events, alerts, and screenupdating, set calculation back to its current state
    With Application
        .Calculation = lCalc    'Set calculation back to its current state
        .EnableEvents = True    'Enable events
        .DisplayAlerts = True   'Enable alerts
        .ScreenUpdating = True  'Enable screenupdating
    End With
    
    'Display error message (if any)
    If Err.Number <> 0 Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If
    
    'Object variable cleanup
    Set ws = Nothing
    Set rngEntries = Nothing
    Set EntryCell = Nothing
    Set rngFindWinner = Nothing
    Erase arrParticipants
    
End Sub