Excel UDF weighted RANDBETWEEN() Excel UDF weighted RANDBETWEEN() vba vba

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.