Random Sorts
Red wants to have a kind-of lottery for his students. He will award them prizes based on a random drawing, but wants to weight each student based on the number of assignments turned in. Normally, I would accomplish this by typing the name of each student in column A one time for every assignment he turned in. If John turned in three assignments, I'd type his name three times. In column B, I'd put a RAND() function and fill it down. Then I'd sort by column B. I'd get something that looks like this:
That's all well and good, but it's missing a few things. If I'm giving away three prizes, Sue wins them all unless I manually exclude her. But the worst part is that it happens too fast. Excel calculates so fast that it's not entertaining to calculate in front of a group (unless you're Charles Williams, of course). I wanted to come up with something that doesn't allow ties, calculates more slowly, and is generally more friendly. Here's my first stab
Behind the button, I have this code:
Dim rNames As Range, rCell As Range
Dim rLastICell As Range
Dim i As Long
FillNames
Set rLastICell = wshDraws.Range("I65536").End(xlUp).Offset(1, 0)
If rLastICell.Row> 2 Then
Set rLastICell = rLastICell.Offset(-1)
Set rNames = wshDraws.Range("I2", rLastICell)
For Each rCell In rNames.Cells
For i = 1 To 50
rCell.Offset(0, 1).Value = Rnd * 1000
Next i
Next rCell
End If
End Sub
Private Sub FillNames()
Dim rNames As Range
Dim rCell As Range, rEntry As Range
Dim i As Long, j As Long
Set rNames = wshDraws.Range("I2")
Set rEntry = wshDraws.Range("A2:A31")
wshDraws.Range("I2:J65536").ClearContents
j = 0
For Each rCell In rEntry.Cells
If Not IsEmpty(rCell.Value) Then
For i = 1 To rCell.Offset(0, 1).Value
rNames.Offset(j).Value = rCell.Value
j = j + 1
Next i
End If
Next rCell
End Sub
The user enters the information in columns A and B, up to 30 students. The code fills column I with one instance of each name for each assignment. Then for each name it fills in a random number between 0 and 999. For show, it fills each cell 50 times to make it look like it's really doing some work.
In column C, I have this array formula
=MAX((rNames=A2)*(rDraws))
and in column D, this
=IF(RANK(C2,$C$2:$C$31)>3,"",CHOOSE(RANK(C2,$C$2:$C$31),"1st Place","2nd Place","3rd Place"))
There's not a lot of error checking and far too many literals in the code, but it's a start.
Download Lotter.zip. Yes, it's 2003 format.
). 
