Excel UDF weighted RANDBETWEEN()
Try this:
Function Probable(v As Variant) As Long Application.Volatile 'remove this if you don't want a volatile function Dim v2 As Variant ReDim v2(LBound(v) To UBound(v) + 1) v2(LBound(v2)) = 0 Dim i As Integer For i = LBound(v) To UBound(v) v2(i + 1) = v2(i) + v(i) / Application.Sum(v) Next i Probable = Application.WorksheetFunction.Match(Rnd(), v2, 1)End Function
The array v
is essentially your outputArray
.
The code takes an array like {1,0,0,1}
and converts it to {0,0.5,0.5,1}
(note the 0
at the beginning) at which point you can do a MATCH
as you suggested to get to get either a 1 or 4
with equal probability.
Similarly, if you were to start with {1,1,1,1}
it would be converted to {0,0.25,0.5,0.75,1}
and return any of 1, 2, 3 or 4
with equal probability.
Also note: you could probably make it a bit quicker if you save the value of Application.Sum(v)
in a variable rather than performing the calculation for every value in array v
.
Update
The function now takesv
as a parameter -- like your code. I also tweaked it a bit so that it can deal with v
having any base, which means you can run it from the worksheet too: =Probable({1,0,0,1})
for example
It appears I have made a tragic mistake. My code was fine, my counting wasn't so good. I was using SUMIF()
instead of COUNTIF()
in my graphing, resulting in later objects in the array (with a higher Index - the output of the UDF which I was supposed to be counting but was instead summing) getting a weighting proportional to their position.
In retrospect, I think someone far more clever than I could probably have deduced that from the information given. I said {1,1,1,1}
has a {10%:20%:30%:40%}
,that's a {1:2:3:4} ratio, which is precisely the same ratio as the indices of the outputs, deduction: the outputs were summed not counted.
Similarly, the graph of {1,0,0,1}
with a {20%:0%:0%:80%}
output, well divide each percentage by it's index (20%/1, 80%/4) and Hey Presto {20%:0%:0%:20%}
, or the 1:1 ratio I had expected.
Something annoying but satisfying in that - knowing the answer was there all along. I suppose there's probably a moral in all this. At least the post can serve as a warning to budding VBAers to check their arithmetic.
This is something I have built, following your logic. It works quite ok, providing different results.
Option ExplicitPublic Function TryMyRandom() As String Dim lngTotalChances As Long Dim i As Long Dim previousValue As Long Dim rnd As Long Dim result As Variant Dim varLngInputArray As Variant Dim varLngInputChances As Variant Dim varLngChancesReedit As Variant varLngInputChances = Array(1, 2, 3, 4, 5) varLngInputArray = Array("a", "b", "c", "d", "e") lngTotalChances = Application.WorksheetFunction.Sum(varLngInputChances) rnd = Application.WorksheetFunction.RandBetween(1, lngTotalChances) ReDim varLngChancesReedit(UBound(varLngInputChances)) For i = LBound(varLngInputChances) To UBound(varLngInputChances) varLngChancesReedit(i) = varLngInputChances(i) + previousValue previousValue = varLngChancesReedit(i) If rnd <= varLngChancesReedit(i) Then result = varLngInputArray(i) Exit For End If Next i TryMyRandom = resultEnd FunctionPublic Sub TestMe() Dim lng As Long Dim i As Long Dim dict As Object Dim key As Variant Dim res As String Set dict = CreateObject("Scripting.Dictionary") For lng = 1 To 1000 res = TryMyRandom If dict.Exists(res) Then dict(res) = dict(res) + 1 Else dict(res) = 1 End If Next lng For Each key In dict.Keys Debug.Print key & " ===> " & dict(key) NextEnd Sub
Concerning your case, make sure that the array is sorted. E.g., in my case speaking about varLngInputChances
. I have not taken a look at the corner cases, there can be an error there, possibly.
Run the TestMe
sub. It will generate even a summary of the results.If you change the variations to varLngInputChances = Array(1, 1, 0, 0, 1)
, it gives:
a ===> 329 b ===> 351 e ===> 320
which is quite good random :) You can change the number of the sample here:For lng = 1 To 1000
, it works quite fast. I have just tried it with 100,000 tests.