|
Randomly selecting a cell weighted on percentage
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. |
Randomly selecting a cell weighted on percentage
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" 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. |
Randomly selecting a cell weighted on percentage
|
Randomly selecting a cell weighted on percentage
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. -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- "mslabbe" wrote: 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. |
Randomly selecting a cell weighted on percentage
Formula in A5 should read as:
=INDEX($A$1:$D$1,MATCH(75%,$A$3:$D$3,1)) -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- |
Randomly selecting a cell weighted on percentage
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)) -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- |
Randomly selecting a cell weighted on percentage
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 "Jim Cone" wrote: 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" 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. |
Randomly selecting a cell weighted on percentage
I have not worked on this long, so I will spend more time, but so far, I
could not get it to work... Thanks " wrote: Hello, I wrote a general UDF for this: http://www.sulprobil.com/html/redw.html HTH, Bernd |
Randomly selecting a cell weighted on percentage
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... "Max" wrote: 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)) -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- |
Randomly selecting a cell weighted on percentage
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" 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 "Jim Cone" wrote: 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" 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. |
Randomly selecting a cell weighted on percentage
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 "Jim Cone" wrote: 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" 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 "Jim Cone" wrote: 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" 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. |
Randomly selecting a cell weighted on percentage
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" 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 |
Randomly selecting a cell weighted on percentage
"mslabbe"wrote:
Thanks for this, as it getting closer for what I'm looking for... Good to hear that .. is there a way that I could by pass sorting the percentages from low to high? 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,SMAL L($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 -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- |
Randomly selecting a cell weighted on percentage
Correction to formula:
In A2: =IF(COLUMN()COUNT($1:$1),"",INDEX(Sheet1!1:1,SMAL L($1:$1,COLUMN()))) Should be: =IF(COLUMN()COUNT($1:$1),"",INDEX(X!1:1,MATCH(SMA LL($1:$1,COLUMN()),$1:$1,0))) -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- |
Randomly selecting a cell weighted on percentage
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" wrote: 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" 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 |
Randomly selecting a cell weighted on percentage
Read the directions.
'------ Jim Cone San Francisco, USA "mslabbe" 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" wrote: 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 -snip- |
Randomly selecting a cell weighted on percentage
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 -- Regards, Tom Ogilvy "Max" wrote in message ... "mslabbe"wrote: Thanks for this, as it getting closer for what I'm looking for... Good to hear that .. is there a way that I could by pass sorting the percentages from low to high? 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,SMAL L($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 -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- |
Randomly selecting a cell weighted on percentage
Errata (wrong source sheetname used earlier):
In A2 should be: =IF(COLUMN()COUNT($1:$1),"",INDEX(Sheet1!1:1,MATC H(SMALL($1:$1,COLUMN()),$1:$1,0))) -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- |
Randomly selecting a cell weighted on percentage
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 |
Randomly selecting a cell weighted on percentage
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 |
Randomly selecting a cell weighted on percentage
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 |
Randomly selecting a cell weighted on percentage
Tom,
Played with your array formula. Manually pressed F9 repetitiously. It occasionally returns #REF! ? I'm not sure whether you got this observation -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- "Tom Ogilvy" wrote in message ... 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 -- Regards, Tom Ogilvy |
Randomly selecting a cell weighted on percentage
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 Singapore http://savefile.com/projects/236895 xdemechanik --- "Jim Cone" wrote in message ... 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 |
Randomly selecting a cell weighted on percentage
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" 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 Singapore http://savefile.com/projects/236895 xdemechanik |
Randomly selecting a cell weighted on percentage
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" 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" 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 Singapore http://savefile.com/projects/236895 xdemechanik |
Randomly selecting a cell weighted on percentage
"Jim Cone" wrote:
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 Singapore http://savefile.com/projects/236895 xdemechanik --- |
Randomly selecting a cell weighted on percentage
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 Singapore http://savefile.com/projects/236895 xdemechanik --- "Tom Ogilvy" wrote in message ... no, I never got this result. Nor did the code which ran it 1000 times. -- Regards, Tom Ogilvy |
Randomly selecting a cell weighted on percentage
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 Singapore http://savefile.com/projects/236895 xdemechanik --- |
Randomly selecting a cell weighted on percentage
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 Singapore http://savefile.com/projects/236895 xdemechanik --- |
Randomly selecting a cell weighted on percentage
Thanks for response, Tom.
Could you clarify how your test sub could be run? I was unable to do this -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- "Tom Ogilvy" wrote in message ... Yes, that was a typo on my part: 40%, 10%, 30%, 10% should have been 40%, 10%, 30%, 20% which is what I actually used. -- Regards, Tom Ogilvy |
Randomly selecting a cell weighted on percentage
"Tom Ogilvy" wrote:
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 .. -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- |
Randomly selecting a cell weighted on percentage
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 "Max" wrote in message ... Thanks for response, Tom. Could you clarify how your test sub could be run? I was unable to do this -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- "Tom Ogilvy" wrote in message ... Yes, that was a typo on my part: 40%, 10%, 30%, 10% should have been 40%, 10%, 30%, 20% which is what I actually used. -- Regards, Tom Ogilvy |
Randomly selecting a cell weighted on percentage
Hi Tom,
Many thanks for the patience and the detailed response (very instructive!) I've got it up and it runs great. -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- Tom Ogilvy wrote: 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 "Max" wrote in message ... Thanks for response, Tom. Could you clarify how your test sub could be run? I was unable to do this -- Max Singapore http://savefile.com/projects/236895 xdemechanik --- "Tom Ogilvy" wrote in message ... Yes, that was a typo on my part: 40%, 10%, 30%, 10% should have been 40%, 10%, 30%, 20% which is what I actually used. -- Regards, Tom Ogilvy |
Randomly selecting a cell weighted on percentage
You guys are da bomb! Works great...many many thanks!
Cheers "Jim Cone" wrote: 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" 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" 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 Singapore http://savefile.com/projects/236895 xdemechanik |
| All times are GMT +1. The time now is 11:45 PM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com