Weighted Random Selection

[Steve C]

Our company is tracking participation in health & nutrition events. I have
setup a spreadsheet listing the employee name in column A, and the number of
events participated in in column B. The list of employees may grow as more
participate. To reward them, we want to do a random drawing for prizes,
based on weighted participation. For example, if each employee's name below
were placed in a fishbowl, Employee01 would be added seven times, Employee02
three times, etc.

Employee01 7
Employee02 3
Employee03 1
Employee04 4
Employee05 2
Employee06 2
Employee07 2
Employee08 1
Employee09 3
Employee10 1

I wrote the following code (attached to a command button) to randomly pick a
winner based on one entry per employee, but how can I use the number of
events in column B to weight the results in favor of greater participation?
Thanks for any help you can offer!

Range("A1").Select 'cell containing first employee name
Range(Selection, Selection.End(xlDown)).Select 'select all listed employees
MyCount = Selection.Cells.Count 'captures count of employees listed

Range("D1").FormulaR1C1 = "=RANDBETWEEN(0," & MyCount & ")" 'produces a
random number between 0 and total number of employees
WinnerNum = Range("D1").Value 'captures the number generated

Range("A1").Select
Winner = ActiveCell.Offset(WinnerNum, 0).Value 'captures name of winning
employee
Range("D2").Value = Winner

 

[Rick Rothstein \(MVP - VB\)]

Just create an array with as many elements as the sum of Column B's values
and put each name into the array as many times as the number next to their
name, then pick a random number between 1 and the sum of Column B and use
that number as the index into the array. This function should do that; it
returns the randomly picked name...

Function RandomPick() As String
Dim X As Long
Dim Z As Long
Dim Sum As Long
Dim Count As Long
Dim LastRow As Long
Dim WeightedNames() As String
Randomize
With Worksheets("Sheet4")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Sum = WorksheetFunction.Sum(.Range("B1:B" & LastRow))
ReDim WeightedNames(1 To Sum)
For X = 1 To LastRow
For Z = 0 To .Cells(X, "B").Value - 1
Count = Count + 1
WeightedNames(Count) = .Cells(X, "A").Value
Next
Next
End With
RandomPick = WeightedNames(Int(Sum * Rnd + 1))
End Function

Rick

 

[Joel]

Use the formula in column C and use Random number between 1 and 26.

A B C

2 Employee01 7 =C1+B2 (7)
3 Employee02 3 =C2+B3 (10)
4 Employee03 1 =C3+B4 (11)
5 Employee04 4 =C4+B5 (15)
6 Employee05 2 =C5+B6 (17)
7 Employee06 2 =C6+B7 (19)
8 Employee07 2 =C7+B8 (21)
9 Employee08 1 =C8+B9 (22)
10 Employee09 3 =C9+B10 (25)
11 Employee10 1 =C10+B11 (26)

 

[Steve C]

Thank you both for your replies. Rick, I made some minor modifications to
your code and everything is working great. Thanks for teaching me something
new in programming code!

 

[Rick Rothstein \(MVP - VB\)]

I'm glad you were able to work out whatever it was that gave you trouble
initially. And, of course, you are welcome for the "lesson".<g>

Rick

 

[Bernd P]

Hello Steve,

You can use my UDF RandHistGrm:
http://www.sulprobil.com/html/histogrm.html

In your example array-enter:
=Index(A1:A10,Int(Randhistogrm(1,1+Count($B$1:$B$10),Transpose($B$1:$B
$10))))

Regards,
Bernd