Excel UDF加权RANDBETWEEN（）

Question

好吧不是真的RANDBETWEEN() 。 我正在尝试创建一个UDF来返回数组中数字的索引，其中数字越大，选择的可能性就越大。

我知道如何在工作表中为随机数分配概率（即在概率之和上使用MATCH() ，SO上有很多东西解释），但我想要一个UDF，因为我将一个特殊的输入数组传入功能 - 不仅仅是一个选定的范围。

我的问题是，加权是关闭的，数组中的数字后面的数字比数组中的数字更有可能被返回，我无法看到我的代码中哪里出错了。 到目前为止这是UDF：

Public Function PROBABLE(ParamArray inputArray() As Variant) As Long
'Takes a set of relative or absolute probabilities and ranks a random number within them
Application.Volatile (True)
Dim outputArray() As Variant
Dim scalar As Single
Dim rankNum As Single
Dim runningTot As Single

'''''
'Here I take inputArray() and convert to outputArray(), 
'which is fed into the probability code below
'''''

scalar = 1 / WorksheetFunction.Sum(outputArray)
rankNum = Rnd()
runningTot = 0

For i = 0 To UBound(outputArray)
    runningTot = runningTot + outputArray(i)
    If runningTot * scalar >= rankNum Then
        PROBABLE = i + 1
        Exit Function
    End If
Next i

End Function

该函数应该查看outputArray()数字的相对大小，并随机选择，但是要对较大的数字加权。 例如， {1,0,0,1} outputArray()应该分别分配{50%,0%,0%,50%}概率。但是，当我测试outputArray() ，1000个样本和100次迭代，并绘制图表返回数组中第1项或第4项的频率，得到了这个结果：

大约20％：80％的分布。 绘制{1,1,1,1} （所有应该有相同的机会）给出10％：20％：30％：40％分布

我知道我错过了一些明显的东西，但我不知道是什么，有什么帮助吗？

UPDATE

有些人要求提供完整的代码，就在这里。

Public Function PROBABLE(ParamArray inputArray() As Variant) As Long
'Takes a set of relative or absolute probabilities and ranks a random number within them
Application.Volatile (True) 'added some dimensions up here
Dim outputArray() As Variant
Dim inElement As Variant
Dim subcell As Variant
Dim scalar As Single
Dim rankNum As Single
Dim runningTot As Single
'convert ranges to values
'creating a new array from the mixture of ranges and values in the input array
''''
'This is where I create outputArray() from inputArray()
''''
ReDim outputArray(0)
For Each inElement In inputArray
'Normal values get copied from the input UDF to an output array, ranges get split up then appended
    If TypeName(inElement) = "Range" Or TypeName(inElement) = "Variant()" Then
        For Each subcell In inElement
            outputArray(UBound(outputArray)) = subcell
            ReDim Preserve outputArray(UBound(outputArray) + 1)
        Next subcell
    'Stick the element on the end of an output array
    Else
        outputArray(UBound(outputArray)) = inElement
        ReDim Preserve outputArray(UBound(outputArray) + 1)
    End If
Next inElement
ReDim Preserve outputArray(UBound(outputArray) - 1)
''''
'End of new code, the rest is as before
''''
scalar = 1 / WorksheetFunction.Sum(outputArray)
rankNum = Rnd()
runningTot = 0

For i = 0 To UBound(outputArray)
    runningTot = runningTot + outputArray(i)
    If runningTot * scalar >= rankNum Then
        PROBABLE = i + 1
        Exit Function
    End If
Next i

End Function

start inputArray() 🡒outputArray outputArray()部分用于标准化不同的输入方法。 即，用户可以输入值，单元格引用/范围和数组的混合，并且该功能可以应对。 例如{=PROBABLE(A1,5,B1:C15,IF(ISTEXT(D1:D3),LEN(D1:D3),0))} （你得到的图片）应该和=PROBABLE(A1:A3) 。 我循环遍历inputArray（）的子元素并将它们放在我的outputArray（）中。 我相当确定这段代码没什么问题。

然后，为了得到我的结果，我将UDF复制到A1:A1000 ，使用COUNTIF(A1:A1000,1) 或代替计数1，我为每个可能的UDF输出计数2,3,4等短宏重新计算表单100次，每次将countif的结果复制到表格中。 我不能确切地说我是怎么做到的，因为我把这一切都留在了工作中，但我会在星期一更新。

Answer 1

尝试这个：

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

---

数组v本质上是您的outputArray 。

代码采用类似{1,0,0,1}的数组并将其转换为{0,0.5,0.5,1} （注意开头的0 ），此时您可以按照建议进行MATCH以相同的概率获得1 or 4 。

类似地，如果你从{1,1,1,1}开始，它将被转换为{0,0.25,0.5,0.75,1}并以相同的概率返回1, 2, 3 or 4任何一个。

另请注意：如果将Application.Sum(v)的值保存在变量中而不是对数组v每个值执行计算，则可能会更快一些。

更新
该函数现在将v作为参数 - 就像您的代码一样。 我也调整了一下，以便它可以处理具有任何基础的v ，这意味着你也可以从工作表中运行它： =Probable({1,0,0,1})

Answer 2

看来我犯了一个悲剧性的错误。 我的代码很好，我的计数不太好。 我在我的图形中使用SUMIF()而不是COUNTIF() ，导致数组中的后续对象（具有更高的索引 - 我应该计算的UDF的输出，而不是求和）获得与他们的立场。

回想起来，我认为有人比我提供的信息更聪明。 我说{1,1,1,1}有{10%:20%:30%:40%} ，这是一个{1：2：3：4}的比例，这与指数的比例正好相同产出，扣除：产出总和未计算。

同样， {1,0,0,1}的图表{1,0,0,1} {20%:0%:0%:80%} ，将每个百分比除以它的指数（20％/ {1,0,0,1} ％/ 4）和嘿Presto {20%:0%:0%:20%} ，或者我预期的1：1比率。

令人烦恼但令人满意的是 - 知道答案一直存在。 我想这一切可能都是道德的。 至少这篇文章可以作为对崭露头角的VBAers的警告，以检查他们的算术。

Answer 3

这是我建立的，遵循你的逻辑。 它工作得很好，提供不同的结果。

Option Explicit
Public 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 = result

End Function

Public 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)
    Next


End Sub

关于您的情况，请确保对数组进行排序。 例如，在我的情况下谈论varLngInputChances 。 我没有看过角落的情况，可能会有错误。

运行TestMe子。 它甚至会生成结果摘要。 如果将变体更改为varLngInputChances = Array(1, 1, 0, 0, 1) ，则会给出：

a ===> 329 b ===> 351 e ===> 320

这是非常好的随机:)你可以在这里改变样本的数量： For lng = 1 To 1000 ，它的工作速度非常快。 我刚尝试了100,000次测试。