Random Name with Multiple Entries

I have uploaded an example workbook to the following link on One Drive

Link removed. Link in post of January 16, 2016 is still valid. Code below is still valid for this answer.

You should be able to download the file, unzip and then insert your list of names with number of tickets into column B and C under the column headers.

Click the button to create a list. It will clear any existing list and prize winners and it creates a list of all the names repeated for the number of times shown in column C.

Click the Draw Raffle button and it will draw one name at a time and insert it against the prize. You can have as many prizes as you like; just add the prizes on the left. You might even want to edit 1st Prize, 2nd Prize etc with the name or description of the actual prize.

The code is designed to select a random row number from 2 to the bottom of the created list and correlates the row number to the name. (the row numbers are the ticket numbers). It cannot repeat a row number so no one gets multiple prizes with the same ticket but it will repeat the names up to the number of tickets for that name.

You can test the code in the workbook before using it with your real data. If you continue to click the Draw Raffle button then it will stop with a message after all tickets have been drawn.

The associated code is below but you can simply use the workbook that I uploaded.

You will need to enable macros in Options. See Help for how to do this. (The option to "Disable all with notification" should be OK.)

Sub CreateList()

    Dim rngNames As Range

    Dim rngCel As Range

    Dim rngDestin As Range

    Dim i As Long

    With Worksheets("Sheet1")

        .Range(.Cells(2, "E"), .Cells(.Rows.Count, "E").End(xlUp)).ClearContents

        .Range(.Cells(2, "I"), .Cells(.Rows.Count, "J")).ClearContents

        Set rngNames = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp))

        .Cells(1, "E") = .Cells(1, "B")

        .Cells(1, "E").Font.Bold = True

        For Each rngCel In rngNames

            Set rngDestin = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)

            For i = 1 To rngCel.Offset(0, 1)

                rngDestin = rngCel.Value

                Set rngDestin = rngDestin.Offset(1, 0)

            Next i

        Next rngCel

        .Columns("E:E").AutoFit

    End With

End Sub

Sub DrawRaffle()

    Dim lngLastRow As Long

    Dim lngDrawRow As Long

    Dim strName As String

    With Worksheets("Sheet1")

        lngLastRow = .Cells(.Rows.Count, "E").End(xlUp).Row

        Do

            If WorksheetFunction.CountA(.Columns("E:E")) = WorksheetFunction.CountA(.Columns("I:I")) Then

                MsgBox "All names have been drawn."

                Exit Sub

            End If

            lngDrawRow = WorksheetFunction.RandBetween(2, lngLastRow)

            If WorksheetFunction.CountIf(.Columns("J:J"), lngDrawRow) = 0 Then

                Exit Do

            End If

        Loop

        .Cells(.Rows.Count, "I").End(xlUp).Offset(1, 0) = .Cells(lngDrawRow, "E").Value

        .Cells(.Rows.Count, "I").End(xlUp).Offset(0, 1) = lngDrawRow

        .Columns("I:J").AutoFit

    End With

End Sub