Weighted lottery help?

[taysomraven]

I am trying to setup a spreadsheet that will allow me conduct and offline weighted lottery. The lottery operates as follows: 14 balls labeled 1 through 14 go into a lotto machine, and then 4 balls are drawn consecutively *without* replacing the balls between each draw. The resulting 4 balls make up a Combination (ie. order doesn't matter.) Using 14 possible balls, and drawing 4 at a time, that means we're working with a total of 1,001 possible combinations (written the high school math way, 14C4 = 1,001). I've used a combination generator to produce all of the 1,001 combinations, which I can copy / paste into a column in a spreadsheet.

Here's what I need help with:

1. Once the combos are in the spreadsheet, I want to assign them randomly AND in a weighed fashion to each of 4 possible people (Randy, Jake, Kyle, and Ted.) For the purpose of this example, we'll use the following names and weights:
   • Randy gets 50% of the combos
   • Jake gets 25%
   • Kyle gets 15%
   • Ted gets 10%
2. The first combo will be drawn (4 balls) and I'll match the combo up to the assigned numbers to find who won (either Ctrl+F, or something more elegant like Index / Match.)
3. The person who won will be removed from the pool of names, and then the weightings will be updated accordingly.
   • For example, if Randy's number gets drawn, then the new weighting would be determined as follows: Jake gets 50% (25/50), Kyle gets 30% (15/50), and Ted gets 20% (10/50). If it's not clear, 25+15+10 = 50, which is the denominator, and the weight the person started with is the numerator.
4. The 1,001 numbers are now assigned again using the updated weightings.
5. Now we just repeat steps 2 through 4 until everyone has been chosen.

So the biggest things I need from the workbook are:
> Randomly assign the combinations to the participants, based on the entered weightings.

> An easy way to remove a participant, recalculate the weightings, and then reassign the numbers after each draw. I'll probably be dealing with at least 10 participants, and the weightings would of course be far different too at that point. A more elegant way of removing participants, and recalculating weightings would be really wonderful (manually is certainly an option, but it's far from ideal.)


Any help is greatly appreciated!

 

[bebo021999]

With the H3:J12 range containing the names of participants and their respective ratiosThe B4:F20 area is the region for displaying the lottery resultsThe RESET button is used to restart from the beginningThe GENERATE button is used to generate results sequentially from B4:F4 downwards to B5:F5,... with each button press.If Randy has a ratio of 50%, it means that regardless of the outcome of this random draw, he has a 50% chance of receiving it.In the code, the last two lines I've temporarily paused it. If you want to test the results, use it to print to the sheet.
How to use: Alt-F11 open VBA window, insert/ module then paste below code into. Save file as .xlsm.

Book1.xlsm

Sheet1 (2) Merge1Begin,Merge2,Merge2,Merge2,Merge2,Merge2,Merge2,Merge2,Merge2,Merge2 Merge1Begin,Merge2,Merge1Begin,Merge2,Merge2,Merge2,Merge2 Merge1Begin,Merge2,Merge2,Merge2,Merge2,Merge1Begin,Merge2,Merge2,Merge2,Merge2 Merge1Begin

docs.google.com

below is the code:

Option Explicit
Sub RandomLottery()
Dim lr&, i&, j&, c&, k&, rsum&, rng, r
Dim winner As Range, sum As Double, res(1 To 1000, 1 To 1)
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Const Num = 14: Const Draw = 4
lr = Range("B20").End(xlUp).Row
Set winner = Range("F3:F" & lr)
Randomize
Do
    r = Int(Rnd * Num) + 1
    If Not dic.exists(r) Then
        dic.Add r, ""
        c = c + 1
    End If
Loop Until c = Draw
Cells(lr + 1, "B").Resize(1, Draw).Value = dic.keys
Set dic = Nothing
lr = Range("H20").End(xlUp).Row
rng = Range("H3:K" & lr).Value2
For i = 1 To UBound(rng)
    If WorksheetFunction.CountIf(winner, rng(i, 2)) = 0 Then
        sum = sum + rng(i, 3)
        rng(i, 4) = sum
    End If
Next
For i = 1 To UBound(rng)
    If rng(i, 4) <> 0 Then
        rng(i, 4) = Round(rng(i, 3) * 100 / sum, 0)
        If i = UBound(rng) Then rng(i, 4) = 100 - rsum
        rsum = rsum + rng(i, 4)
    End If
Next
For i = 1 To UBound(rng)
    If rng(i, 4) > 0 Then
        For j = 1 To rng(i, 4)
            k = k + 1: res(k, 1) = rng(i, 2)
        Next
    End If
Next
r = Int(Rnd * 100) + 1
Range("F20").End(xlUp).Offset(1, 0).Value = res(r, 1)
'Range("L3").Resize(UBound(rng), UBound(rng, 2)).Value = rng
'Range("M10").Resize(UBound(res)).Value = res
End Sub
Sub delete()
If MsgBox("You are about to clear all!", vbYesNo) = vbNo Then Exit Sub
Range("B4:F100").ClearContents
End Sub

 

[taysomraven]

With the H3:J12 range containing the names of participants and their respective ratiosThe B4:F20 area is the region for displaying the lottery resultsThe RESET button is used to restart from the beginningThe GENERATE button is used to generate results sequentially from B4:F4 downwards to B5:F5,... with each button press.If Randy has a ratio of 50%, it means that regardless of the outcome of this random draw, he has a 50% chance of receiving it.In the code, the last two lines I've temporarily paused it. If you want to test the results, use it to print to the sheet.
How to use: Alt-F11 open VBA window, insert/ module then paste below code into. Save file as .xlsm.

Book1.xlsm

Sheet1 (2) Merge1Begin,Merge2,Merge2,Merge2,Merge2,Merge2,Merge2,Merge2,Merge2,Merge2 Merge1Begin,Merge2,Merge1Begin,Merge2,Merge2,Merge2,Merge2 Merge1Begin,Merge2,Merge2,Merge2,Merge2,Merge1Begin,Merge2,Merge2,Merge2,Merge2 Merge1Begin

docs.google.com

below is the code:

Option Explicit
Sub RandomLottery()
Dim lr&, i&, j&, c&, k&, rsum&, rng, r
Dim winner As Range, sum As Double, res(1 To 1000, 1 To 1)
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Const Num = 14: Const Draw = 4
lr = Range("B20").End(xlUp).Row
Set winner = Range("F3:F" & lr)
Randomize
Do
    r = Int(Rnd * Num) + 1
    If Not dic.exists(r) Then
        dic.Add r, ""
        c = c + 1
    End If
Loop Until c = Draw
Cells(lr + 1, "B").Resize(1, Draw).Value = dic.keys
Set dic = Nothing
lr = Range("H20").End(xlUp).Row
rng = Range("H3:K" & lr).Value2
For i = 1 To UBound(rng)
    If WorksheetFunction.CountIf(winner, rng(i, 2)) = 0 Then
        sum = sum + rng(i, 3)
        rng(i, 4) = sum
    End If
Next
For i = 1 To UBound(rng)
    If rng(i, 4) <> 0 Then
        rng(i, 4) = Round(rng(i, 3) * 100 / sum, 0)
        If i = UBound(rng) Then rng(i, 4) = 100 - rsum
        rsum = rsum + rng(i, 4)
    End If
Next
For i = 1 To UBound(rng)
    If rng(i, 4) > 0 Then
        For j = 1 To rng(i, 4)
            k = k + 1: res(k, 1) = rng(i, 2)
        Next
    End If
Next
r = Int(Rnd * 100) + 1
Range("F20").End(xlUp).Offset(1, 0).Value = res(r, 1)
'Range("L3").Resize(UBound(rng), UBound(rng, 2)).Value = rng
'Range("M10").Resize(UBound(res)).Value = res
End Sub
Sub delete()
If MsgBox("You are about to clear all!", vbYesNo) = vbNo Then Exit Sub
Range("B4:F100").ClearContents
End Sub

I really appreciate you taking the time to do this, but it seems like this sheet handles the entire lottery electronically. My intent is to handle the drawing of balls physically with an actual lotto ball machine, and then reference the spreadsheet to find out [after each draw] who is to be awarded the next draft spot. Don't get me wrong, this script is great and would be exactly what I would need if I didn't want to do the drawings myself, physically. Obviously the fact that I do makes this more difficult because we're now talking about me changing the data on the fly and then trying to have the sheet react properly, rather than just letting it do the whole thing itself.

 

[taysomraven]

I feel like I could've done a better job explaining what I'm after in my OP, but I can't edit it, so I'm just going to comment again here to try and explain more thoroughly.

I'm trying to run a weighted draft lottery using physical lotto balls for my fantasy league. Here's the catch - I don't just want to draw for the 1st and 2nd picks, I want to draw for the worse picks first, and work all the way down to the #1 pick (I just think it'll be more fun for the league.)


===== LOTTO METHODOLOGY ===== (skip if you're a familiar already)
To do this, I'm using a lotto machine containing 14 balls which are labeled 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14. To award a pick, four balls are drawn consecutively *without* replacing them -- this type of draw scheme yields a total of 1,001 possible Combinations of the four balls, because as you may recall, order doesn't matter when dealing with Combinations (written the high-school-math-way, 14C4 = 1,001). 1,000 of those combinations will have been assigned to the participating managers using specific weightings, and when a draw is completed it will be matched up with the assigned numbers to determine which manager receives the pick. The one remaining combo that wasn't assigned will be a redraw (usually it's 11, 12, 13, 14.)

To get started, I've used a combination generator to produce all of the 1,001 combinations, which I can copy / paste into a spreadsheet column. Once the combos are in the spreadsheet, I need to assign them randomly to the managers, using the appropriate weightings. Next, the first combo will be drawn (4 balls) and I'll match that combo up to the the manager who was assigned that particular combo (either Ctrl+F, or something more elegant like Index / Match.) The manager who won will be removed from the pool of names, and then the weightings refactored accordingly; all 1,000 combos will once again be allocated in a weighted manner to the remaining managers. The next draw will be completed, and the same process will repeat until all managers have been assigned a draft pick.


===== EXAMPLE =====
Let's use Randy, Jake, Kyle and Ted as our managers; in reality it will be more people, but we'll keep it simple for now. Below are their assigned weightings.

• Randy gets 50% of the combos (so 500 of the combinations)
• Jake gets 25% (aka 250 combos)
• Kyle gets 15% (150 combos)
• Ted gets 10% (100 combos)

Let's say that one of Randy's assigned combos gets drawn, and he's awarded the pick. The new [refactored] weightings would be as follows: Jake gets 50% (25/50), Kyle gets 30% (15/50), and Ted gets 20% (10/50). If it's not clear how I'm refactoring, I'm taking the initially awarded weightings of the remaining managers, adding them together, using that number as the denominator, and the original weighting as the numerator. So 25+15+10 = 50, which is the denominator, and the manager's original weighting acts as the numerator.


===== WHAT I NEED FROM EXCEL WORKBOOK =====

1. Ability to randomly assign the combinations to participants, using assigned weightings.
2. Ability to remove managers and then refactor the weightings on-the-fly.
3. Ability to reassign all combos randomly using the refactored weightings after each draw.
4. Ability to handle however many participants are involved, and whatever initial weightings are agreed upon.

Thanks!

 

[bebo021999]

OK, now it is clear for me.
Update your participants list in H:J
Click "RESET" to reset if you want to clear all in B:F
Click "GENERATE" to generate new combination base on participants list
After your manual lottery draw complete for each set of 4 balls complete, manual input in M to P (in any order)
The winner would be in column Q, arcording to combination in M:P, found in B:E

Book1.xlsm

Sheet1 (2) Merge1Begin,Merge2,Merge2,Merge2,Merge2,Merge2,Merge2,Merge2,Merge2,Merge2 Merge1Begin,Merge2,Merge1Begin,Merge2,Merge2,Merge2,Merge2 Merge1Begin,Merge2,Merge2,Merge2,Merge2,Merge1Begin,Merge2,Merge2,Merge2,Merge2 Merge1Begin

docs.google.com

 

[taysomraven]

I really appreciate the help. This got me VERY close to a solution, but I somehow broke the VBA in a way that it can't seem to overcome while modifying the sheet to accommodate my needs, and I really am not good enough to know how to read or troubleshoot VBA code. The sheet I modded is provided below.

Draft Lottery - update - Copy.xlsm

Sheet1 Participants list,Randomizer Columns Combinations,No,Name,Weight %,Chances,Order,Manager,Current Weight,Adj Weights,Orig Weights,Winner Combos,1st,2nd,3rd,4th,Assigned name,1,0,1,Randy,,,32.80%,X ,2,0,2,Jake,,,22.30%,X ,3,0,3,Kyle,36.20%,15.10%, ,4,0,4,Ted,24.50%,10.20%, ,5,0,5,aaa,16.80%...

docs.google.com

The issue occurred when I used

=@S:S

and also

=@T:T

in columns I and J respectively. After I made that change, the "Generate" VBA breaks, and even if I remove the formulas in columns I & J the VBA still tosses me "Run-time error '13'": Type mismatch." If I go to Debug, it points out the following:

Thank you again for the help!

 

[bebo021999]

So the "rng" should be adjusted to new range, M:P, with name is in column 1 and rate is in column 4
rng = Range("M3:P" & lr).Value2

then the final code is:

Option Explicit
Sub RandomLottery()
Dim lr&, i&, j&, k&, c&, rng, r
Dim i1&, i2&, i3&, i4&, comb&
Dim winner As Range, sum As Double, res(1 To 100000, 1 To 5)
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Const Num = 14: Const Draw = 4
comb = WorksheetFunction.Combin(Num, Draw)
lr = Range("I20").End(xlUp).Row
rng = Range("M3:P" & lr).Value2 ' adjust new range
For j = 1 To UBound(rng)
    sum = sum + rng(j, 4) * comb
    rng(j, 2) = sum
Next
For i1 = 1 To Num
    For i2 = i1 + 1 To Num
        For i3 = i2 + 1 To Num
            For i4 = i3 + 1 To Num
                If i1 <> i2 And i2 <> i3 And i3 <> i4 Then
                    k = k + 1: res(k, 1) = i1: res(k, 2) = i2
                    res(k, 3) = i3: res(k, 4) = i4
                    For j = 1 To UBound(rng)
                        If k <= rng(j, 2) Then
                            res(k, 5) = rng(j, 1)
                            Exit For
                        End If
                    Next
                End If
            Next
        Next
    Next
Next
Range("B4").Resize(k, 5).Value = res
End Sub
Sub delete()
If MsgBox("You are about to clear all!", vbYesNo) = vbNo Then Exit Sub
Range("B4:F10000").ClearContents
End Sub

 

[taysomraven]

Unfortunately tweaking the range as suggested appears to have no effect on the macro failing. It still points out the same line (sum = sum + rng(j, 2) * comb.

Any additional help is much appreciated!

 

[Joe4]

I don't know if this is the issue or not, but it is STRONGLY recommended NEVER to use reserved words (names of existing functions, properties, methods, objects, etc) as the names of Variables, Procedures or Functions. Doing so can cause errors and/or unexpected results.

Since "sum" is the name of an existing function in Excel, you should NOT use it as a variable in VBA.

 

[taysomraven]

I don't know if this is the issue or not, but it is STRONGLY recommended NEVER to use reserved words (names of existing functions, properties, methods, objects, etc) as the names of Variables, Procedures or Functions. Doing so can cause errors and/or unexpected results.

Since "sum" is the name of an existing function in Excel, you should NOT use it as a variable in VBA.

You're saying that the way "sum" is being used in this code isn't standard? I assumed it was a term that VBA naturally recognizes - is that not the case? I guess the part that has me confused is there's also and "rsum" in the code, which would lead me to believe that it is in fact a recognized function in VBA. If it isn't, I supposed I could comb through and find all instances of "sum" and replace it with "bagofchips" or whatever random string I come up with. Do you suppose that would help?

EDIT: I just went through and changed all instances of "sum" to "AddUp", saved the workbook with a separate name, and tried the macro again. It still gives the same error, and points to the exact same line of VBA code when I click 'Debug'.