Randomly selecting a cell weighted on percentage

G

Guest

I'm trying to figure out away that I can randomly pick an item from a range
and have the random function be weighted. So lets say in cell A1 = apples,
B1 = bananas, C1 = pears and D1 = oranges. In the cells below them are there
chances, the higher the %, the better the chance it will be selected. So for
instance, A2 = 30%, B2 = 20%, C2 = 40% and D2 = 10%. So, C2 has the best
chance at being randomly selected.

Anyone have any ideas on how to accomplish this? I really do not know where
to even begin. So, any help or ideas would be greatly appreciated.
 
J

Jim Cone

Sub WeighTheChoices()
Dim varArr As Variant
Dim N As Long
'Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Randomize
N = Int(10 * Rnd)
varArr = Array(10, 20, 20, 30, 30, 30, 40, 40, 40, 40)
MsgBox "The winner is the one with a " & varArr(N) & "% chance. "
End Sub
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware


"mslabbe" <[email protected]>
wrote in message
I'm trying to figure out away that I can randomly pick an item from a range
and have the random function be weighted. So lets say in cell A1 = apples,
B1 = bananas, C1 = pears and D1 = oranges. In the cells below them are there
chances, the higher the %, the better the chance it will be selected. So for
instance, A2 = 30%, B2 = 20%, C2 = 40% and D2 = 10%. So, C2 has the best
chance at being randomly selected.

Anyone have any ideas on how to accomplish this? I really do not know where
to even begin. So, any help or ideas would be greatly appreciated.
 
G

Guest

One formulas play to try ..

First, sort the data in ascending order by percentage from left to right
eg in A1:D2 would be:

oranges bananas apples pears
10% 20% 30% 40%

Enter a zero in A3
Put in B3: =SUM($A$2:A2)
Copy B3 to D3

Then place in any cell, say in A5:
=INDEX($A$1:$D$1,MATCH(RAND(),$A$3:$E$3,1))

A5 will generate the required "weighted" random draw which takes into
account the commensurate chances by each fruit's percentage. This is achieved
via the cumulative percentages in A3:D3 which produces the unique
"buckets/tiers" corresponding to the sorted percentages in A2:D2. Press F9 to
re-generate.
 
M

Max

Disregard the earlier which was wrong. Sorry ..

Formula in A5 should read as:
=INDEX($A$1:$D$1,MATCH(RAND(),$A$3:$D$3,1))

---
 
G

Guest

Thanks Jim, but it looks like I will be stuck with the percentages, right?
Or I have to change the array in the formula you have made...would you have a
way that when the percentages change, that the formula change? And if I
added another fruit?

Thanks again
 
G

Guest

I have not worked on this long, so I will spend more time, but so far, I
could not get it to work...

Thanks
 
G

Guest

Max...is there a way that I could by pass sorting the percentages from low to
high?

Thanks for this, as it getting closer for what I'm looking for...
 
J

Jim Cone

I doubt if I can help you further. However you do need to confirm if...

the number of fruits is not fixed?
the weightings used are not fixed?
the data is always laid out in rows with the fruits directly above the percentages?

Jim Cone
San Francisco, USA
http://www.officeletter.com/blink/specialsort.html




"mslabbe" <[email protected]>
wrote in message
Thanks Jim, but it looks like I will be stuck with the percentages, right?
Or I have to change the array in the formula you have made...would you have a
way that when the percentages change, that the formula change? And if I
added another fruit?

Thanks again
 
G

Guest

Well if you can't, you still got farther then I did, lol. To answer your
questions:

the number of fruits is not fixed? No, they could increase and decrease in
different fruit types

the weightings used are not fixed? No, they will change based on another
formula

the data is always laid out in rows with the fruits directly above the
percentages? Yes, the percentages will be below the fruit.

One thing that might help, if I know there will be a max number of
fruit...picking a number, say 18 or 28, would that help? and for the fruit
not in the selection, the percentages are 0% so they would not be selected?

Not sure if that helps
Thanks again
Cheers
 
J

Jim Cone

This seems to work. However the larger the selection the longer
it takes to fill the array/calculate. It was taking several seconds on 11 cells.
This is not code for a wimpy computer. <g> The array can get quite large...
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware

Sub WhoIsIt()
MsgBox TipTheScales(Selection)
End Sub

Function TipTheScales(ByRef rng As Excel.Range) As Variant
'Picks a random value using weighted percent values in the selection.
'Percent values should be entered as a whole number.
'Return value is from the cell text directly above the chosen percent value.
'Requires a reference (in the VBE) to ATPVBAIN.XLA in Tools | References
'Jim Cone - San Francisco, USA - December 31, 2006
Dim varArr() As Variant
Dim N As Long
Dim i As Long
Dim j As Long
Dim lngLcm As Long
Dim lngPortion As Long

If Application.Sum(rng) <> 100 Then
TipTheScales = "Selection values must total 100. "
Exit Function
ElseIf rng.Rows.Count <> 1 Then
TipTheScales = "Select only one row. "
Exit Function
Else
For N = 1 To rng.Count
If Not IsNumeric(rng(N)) Then
TipTheScales = "All entries in the selection must be numbers. "
Exit Function
End If
Next
End If
'Least Common Multiple
lngLcm = Lcm(rng)
ReDim varArr(1 To lngLcm, 1 To 2)
For N = 1 To rng.Count
lngPortion = (lngLcm * rng(N).Value) / 100
For i = 1 To lngPortion
varArr(j + i, 1) = rng(N).Value
varArr(j + i, 2) = rng(N).Offset(-1, 0).Value
Next
j = j + lngPortion
Next
'Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Randomize
N = Int(lngLcm * Rnd) + 1
TipTheScales = varArr(N, 2) & " is a winner. "
End Function
'---------------------



"mslabbe" <[email protected]>
wrote in message
Well if you can't, you still got farther then I did, lol.
To answer your questions:

the number of fruits is not fixed?
No, they could increase and decrease in different fruit types

the weightings used are not fixed?
No, they will change based on another formula

the data is always laid out in rows with the fruits directly above the percentages?
Yes, the percentages will be below the fruit.

One thing that might help, if I know there will be a max number of
fruit...picking a number, say 18 or 28, would that help? and for the fruit
not in the selection, the percentages are 0% so they would not be selected?
Not sure if that helps
Thanks again
Cheers
 
M

Max

"mslabbe"wrote:
Thanks for this, as it getting closer for what I'm looking for...
Click to expand...

Good to hear that ..
is there a way that I could
by pass sorting the percentages from low to high?
Click to expand...

Not versed in vba, sorry.
Maybe others will jump in here.

Using formulas, I could try this set up ..

Assuming source data in Sheet1's rows1 and 2, from col A across to col IV,
fruits in A1 across, corresponding percentages in A2 across

In another sheet,

In A1:
=IF(Sheet1!A2="","",Sheet1!A2+COLUMN()/10^10)

In A2:
=IF(COLUMN()>COUNT($1:$1),"",INDEX(Sheet1!1:1,SMALL($1:$1,COLUMN())))

Copy A2 down to A3. Select A1:A3, copy across to IV3. Hide away row1. Rows 2
& 3 returns the required ascending auto-sort (left to right) of Sheet1's
fruits & percents.

Then just set it up as before ..

Enter a zero in A4
Put in B4: =SUM($A$3:A3)
Copy B4 across to IV4

Place in any cell, say in A5:
=INDEX(2:2,MATCH(RAND(),4:4,1))
to generate the "weighted" random draw

---
 
M

Max

Correction to formula:
In A2:
=IF(COLUMN()>COUNT($1:$1),"",INDEX(Sheet1!1:1,SMALL($1:$1,COLUMN())))
Click to expand...

Should be:
=IF(COLUMN()>COUNT($1:$1),"",INDEX(X!1:1,MATCH(SMALL($1:$1,COLUMN()),$1:$1,0)))


---
 
G

Guest

I think I got something that will work, but it is a formula based using the
RAND() function, which always calculates when editing.

I tried using this code, but I get a a "Compile error: Sub Function not
define" and the Lcm is highlighted after the "=" sign in:

'Least Common Multiple
lngLcm = Lcm(rng)

Not sure why
 
J

Jim Cone

Read the directions.
'------
Jim Cone
San Francisco, USA



"mslabbe" <[email protected]>
wrote in message
I think I got something that will work, but it is a formula based using the
RAND() function, which always calculates when editing.

I tried using this code, but I get a a "Compile error: Sub Function not
define" and the Lcm is highlighted after the "=" sign in:
'Least Common Multiple
lngLcm = Lcm(rng)

Not sure why

Jim Cone said:
This seems to work. However the larger the selection the longer
it takes to fill the array/calculate. It was taking several seconds on 11 cells.
This is not code for a wimpy computer. <g> The array can get quite large...
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware

Sub WhoIsIt()
MsgBox TipTheScales(Selection)
End Sub

Function TipTheScales(ByRef rng As Excel.Range) As Variant
'Picks a random value using weighted percent values in the selection.
'Percent values should be entered as a whole number.
'Return value is from the cell text directly above the chosen percent value.
'Requires a reference (in the VBE) to ATPVBAIN.XLA in Tools | References
'Jim Cone - San Francisco, USA - December 31, 2006
Click to expand...
-snip-
 
T

Tom Ogilvy

There is no need to sort the percentages before using your approach of
accumulating the percentages as long as they add up to 1.

A play off your formula

=INDEX(A1:D1,1,MATCH(RAND(),CHOOSE(ROW(1:5),0,SUM($A$2:$A$2),SUM($A$2:$B$2),SUM($A$2:$C$2),SUM($A$2:$D$2))))

array entered, works and the percentages are not sorted.


I had 40%, 10%, 30%, 10% and got consistent results with this test macro:

Sub abcd()
Dim v(1 To 4)
maxVal = 1000
For i = 1 To maxVal
ActiveSheet.Calculate

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
For i = 1 To 4
vsum = vsum + v(i)
v(i) = v(i) / maxVal
Cells(1, 10 + i) = v(i)
Next
Cells(1, 10 + 6) = vsum
End Sub
 
M

Max

Errata (wrong source sheetname used earlier):

In A2 should be:
=IF(COLUMN()>COUNT($1:$1),"",INDEX(Sheet1!1:1,MATCH(SMALL($1:$1,COLUMN()),$1:$1,0)))

---
 
J

Jim Cone

Also, the AnalysisToolPak must be checkmarked in Tools | Add-ins.

The code below is modified slightly. It fixes a subscript out of range error,
adds a status bar message, adds some checks before the program runs
and an error handler...

Function TipTheScales_R1(ByRef rng As Excel.Range) As Variant
'---
'Picks a random value using weighted percent values in the selection.
'Percent values should be entered as a whole number.
'Return value is the cell text directly above the chosen percent value.
'Requires a reference (in the VBE) to ATPVBAIN.XLA in Tools | References
'Jim Cone - San Francisco, USA - December 31, 2006
'---
On Error GoTo OverWeight_Err
Dim varArr() As Variant
Dim varSum As Variant
Dim N As Long
Dim i As Long
Dim j As Long
Dim lngLcm As Long
Dim lngValue As Long
Dim lngPortion As Long

varSum = Application.Sum(rng)

If IsError(varSum) Then
TipTheScales_R1 = "Selection values must total 100. "
Exit Function
ElseIf varSum <> 100 Then
TipTheScales_R1 = "Selection values must total 100. "
Exit Function
ElseIf rng.Rows.Count <> 1 Then
TipTheScales_R1 = "Select only one row. "
Exit Function
Else
For N = 1 To rng.Count
If Not IsNumeric(rng(N)) Or Len(rng(N)) = 0 Then
TipTheScales_R1 = "All entries in the selection must be numbers. "
Exit Function
End If
Next
End If

'Least Common Multiple
lngLcm = Lcm(rng)
ReDim varArr(1 To lngLcm, 1 To 2)
For N = 1 To rng.Count
lngValue = rng(N).Value
lngPortion = Int(lngLcm * lngValue / 100)
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(lngLcm * Rnd) + 1
Application.Calculation = xlCalculationAutomatic
TipTheScales_R1 = varArr(N, 2) & " is a winner. "
Erase varArr
Set rng = Nothing
Exit Function
OverWeight_Err:
Beep
TipTheScales_R1 = "Error " & Err.Number & " - " & Err.Description
End Function

Sub WhoIsIt()
Application.Calculation = xlCalculationManual
MsgBox TipTheScales_R1(Selection)
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End Sub
 
B

bplumhoff

Hello again,

If you take my UDF you can use
=INDEX($A$1:$D$1,INT(redw($A$2,$B$2,$C$2,$D$2)*4+1))
for example.
If you need an additional fruit, change the formula to
redw(...,$E$2)*5+1 ...
Nice thing about this UDF is that the sum of all weights does not need
to be 1. The complexity is hidden in the UDF (ok, it is not that
complex).

Regards,
Bernd
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Weighted Random Selection 5
Macro to align & compare multiple columns with several rows 4
How do I calculate a weighted average and exclude the empthy cells 2
Is there a formula that can do this? 3
Macro that analyses 3 columns and put results in 4th 5
MACRO RUN random percentage and copy of column values 1
Column picked randomly with probability relative to number of entr 4
Matching Data between 2 Tabs on Same Workbook - then calculating 2

Top