Randomly selecting a cell weighted on percentage

[Guest]

Jim...I could not find my office cd, as I was trying to apply the Add-on and
it was asking for the disk. I'm going away for the rest of the week...I will
try this when I get back

Thanks for the help and Happy New Year

 

[Max]

Tom,
Played with your array formula. Manually pressed F9 repetitiously.
It occasionally returns #REF! ?
I'm not sure whether you got this observation

 

[Max]

Hi Jim,

Happy New Year !

In VBE Tools > References,
I checked: atpvbaen.xls instead
(could not find ATPVBAIN.XLA)

But think I got your sub running well

How could your Sub WhoIsIt() be tweaked to write the results of say, 10 runs
into a col range instead ? Thanks.

 

[Jim Cone]

Hi Max,
Besides making the spelling error, I think I created a pile of crap.
If the percentages total 100 then you don't need the LCM.
If they don't total 100 then it becomes a guess as to how
to distribute the weightings.
Do you recall "Springtime for Hitler", where the "producers" sold
multiple 50% shares of the production to gullible old people?
I am sure I was involved in that somewhere.
Regards,
Jim Cone

"Max" <[email protected]>
wrote in message
Hi Jim,
Happy New Year !
In VBE Tools > References,
I checked: atpvbaen.xls instead
(could not find ATPVBAIN.XLA)

But think I got your sub running well
How could your Sub WhoIsIt() be tweaked to write the results of say, 10 runs
into a col range instead ? Thanks.

 

[Jim Cone]

Max and mslabbe,
I think I am in a better mood now. <g>
Here is something that provides a list of 10 consecutive winners in Column B.
(I hope)
The next ten (if run) would go directly underneath the previous ten.
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware


Function TipTheScales_R2(ByRef rng As Excel.Range) As Variant
'Jim Cone - San Francisco, USA - January 02, 2007
'Called by sub PickWinner_R2
On Error GoTo OverWeight_Err
Dim varArr() As Variant
Dim N As Long
Dim i As Long
Dim j As Long
Dim lngValue As Long
Dim lngPortion As Long


ReDim varArr(1 To 100, 1 To 2)
For N = 1 To rng.Count
lngValue = rng(N).Value
lngPortion = Int(lngValue)
For i = 1 To lngPortion
varArr(j + i, 1) = lngValue
varArr(j + i, 2) = rng(N).Offset(-1, 0).Value
Next
j = j + lngPortion
Application.StatusBar = " WORKING " & Format$(N / rng.Count, "#00%")
Next
'Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Randomize
N = Int(100 * Rnd) + 1
Application.Calculation = xlCalculationAutomatic
TipTheScales_R2 = varArr(N, 2)
Erase varArr
' Set rng = Nothing
Exit Function
OverWeight_Err:
Beep
TipTheScales_R2 = "Error " & Err.Number & " - " & Err.Description
End Function

Sub PickWinner_R2()
'Picks a random value using weighted percent values in the selection.
'Percent values should be entered as a whole number in a single row.
'Return value is the cell text directly above the chosen percent value.
'Calls function TipTheScales.
'Returns 10 consecutive picks in column B.
'Jim Cone - San Francisco, USA - January 02, 2007
'---
Dim Rw As Long
Dim N As Long
Dim varSum As Variant
Dim rngNums As Excel.Range

Set rngNums = Selection
varSum = Application.Sum(rngNums)

If IsError(varSum) Then
MsgBox "Sections values must total 100. "
Exit Sub
ElseIf varSum <> 100 Then
MsgBox "Selection values must total 100. "
Exit Sub
ElseIf Selection.Rows.Count <> 1 Then
MsgBox "Select only one row. "
Exit Sub
Else
For N = 1 To rngNums.Count
If Not IsNumeric(rngNums(N)) Or Len(rngNums(N)) = 0 Then
MsgBox "All entries in the rngnums must be numbers. "
Exit Sub
End If
Next
End If
Application.Calculation = xlCalculationManual
Rw = Cells(Rows.Count, 2).End(xlUp)(2, 1).Row
For N = Rw To Rw + 9
Cells(N, 2).Value = TipTheScales_R2(rngNums)
Next
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
Set rngNums = Nothing
End Sub
'------------


"Jim Cone" <[email protected]>
wrote in message
Hi Max,
Besides making the spelling error, I think I created a pile of crap.
If the percentages total 100 then you don't need the LCM.
If they don't total 100 then it becomes a guess as to how
to distribute the weightings.
Do you recall "Springtime for Hitler", where the "producers" sold
multiple 50% shares of the production to gullible old people?
I am sure I was involved in that somewhere.
Regards,
Jim Cone

"Max" <[email protected]>
wrote in message
Hi Jim,
Happy New Year !
In VBE Tools > References,
I checked: atpvbaen.xls instead
(could not find ATPVBAIN.XLA)

But think I got your sub running well
How could your Sub WhoIsIt() be tweaked to write the results of say, 10 runs
into a col range instead ? Thanks.

 

[Max]

Max and mslabbe,
I think I am in a better mood now. <g>
Here is something that provides a list of 10 consecutive
winners in Column B. (I hope)
The next ten (if run) would go directly underneath the previous ten. ...

Jim, many thanks! Yes, it runs as you stated above.
Fabulous.

---

 

[Max]

Hi Tom,

Many thanks for the response

I still get occasional #REF!'s with your array* formula when F9 was
repeatedly pressed to regen. *it's placed in A6 in Sheet1 in the test file
(link below)

Here's my test file:
http://cjoint.com/?bdalG2gJoT
Weighted Random Draw_1a.xls

As I didn't quite understand how to set-up the sheet? to run your test
macro: Sub abcd(), this part wasn't done. Perhaps you could kindly clarify
on this as I'd like to test run your sub. Thanks.

 

[Max]

I still get occasional #REF!'s with your array* formula when F9 was

repeatedly pressed to regen...

Could it be because the lookup_array (returned by CHOOSE(...))
needs to be sorted in ascending order since match_type 1 is used?

---

 

[Max]

Ahh, think I've discovered why the occasional REF error kept popping up

I had used the data mentioned in your line to set it up on the sheet:

I had 40%, 10%, 30%, 10% ..

w/o realizing the percents don't add up to 100% <g>
Once the above was corrected, there's no more REF error

But I'd still like to test run your sub abcd().
Grateful if you could clarify

---

 

[Max]

Thanks for response, Tom.

Could you clarify how your test sub could be run?
I was unable to do this

 

[Max]

Here is a modification that doesn't require
the weights to be whole numbers
or to add up to 100 and doesn't
depend on building a large array ...

Runs great, Tom !
A marvellous modification ..

---

 

[Tom Ogilvy]

Range("F2").Value refers the cell that contains the formula to return the
random/weighted selection. As you recall the formula contained the rand()
function, so it is volatile. The F2 can be specified to be any cell. As
the code is written, it assumes 4 possible outcome/weights with the formula
returning either Peaches, Pears, Apples or Bananas on each calculate.
(easily modifiable.)

Sub abcd()
Dim v(1 To 4)

' choose the number of iterations
maxVal = 1000

' code loops maxVal times
For i = 1 To maxVal

' issue a calculate to cause the volatile formula
' to recalculate and return a new random selection

ActiveSheet.Calculate


' the case statement assumes that the cells corresponding to the
' weights contain the string Pears, Apples, Peaches and Bananas - case
sensative

Select Case Range("F2").Value
Case "Pears" ' 40%
v(1) = v(1) + 1
Case "Apples" ' 10%
v(2) = v(2) + 1
Case "Peaches" ' 30%
v(3) = v(3) + 1
Case "Bananas" ' 20%
v(4) = v(4) + 1
End Select
Next

'The percentage each result was returned by the formula
' is written to K1:N1
For i = 1 To 4
vsum = vsum + v(i)
v(i) = v(i) / maxVal
Cells(1, 10 + i) = v(i)
Next

' the sum of the percentages is shown at cell P1
Cells(1, 10 + 6) = vsum
End Sub

--
Regards,
Tom Ogilvy

Thanks for response, Tom.

Could you clarify how your test sub could be run?
I was unable to do this

---

 

[Max]

Hi Tom,

Many thanks for the patience and the detailed response (very
instructive!)
I've got it up and it runs great.

---

Range("F2").Value refers the cell that contains the formula to return the
random/weighted selection. As you recall the formula contained the rand()
function, so it is volatile. The F2 can be specified to be any cell. As
the code is written, it assumes 4 possible outcome/weights with the formula
returning either Peaches, Pears, Apples or Bananas on each calculate.
(easily modifiable.)

Sub abcd()
Dim v(1 To 4)

' choose the number of iterations
maxVal = 1000

' code loops maxVal times
For i = 1 To maxVal

' issue a calculate to cause the volatile formula
' to recalculate and return a new random selection

ActiveSheet.Calculate


' the case statement assumes that the cells corresponding to the
' weights contain the string Pears, Apples, Peaches and Bananas - case
sensative

Select Case Range("F2").Value
Case "Pears" ' 40%
v(1) = v(1) + 1
Case "Apples" ' 10%
v(2) = v(2) + 1
Case "Peaches" ' 30%
v(3) = v(3) + 1
Case "Bananas" ' 20%
v(4) = v(4) + 1
End Select
Next

'The percentage each result was returned by the formula
' is written to K1:N1
For i = 1 To 4
vsum = vsum + v(i)
v(i) = v(i) / maxVal
Cells(1, 10 + i) = v(i)
Next

' the sum of the percentages is shown at cell P1
Cells(1, 10 + 6) = vsum
End Sub

 

[Guest]

You guys are da bomb! Works great...many many thanks!

Cheers