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()中数字的相对大小，并随机选择，但加权较大的数字。例如。 outputArray()的{{1}}应分别分配{1,0,0,1}的概率但是当我测试{50%,0%,0%,50%}时，1000个样本和100次迭代，并绘制了项目1或项目4的频率。我得到了这个结果：

大约20％：80％的分布。绘制outputArray()（所有人应该有相同的机会）给出了10％：20％：30％：40％分布

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

更新

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

{1,1,1,1}

开始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 inputArray()部分用于标准化不同的输入方法。即用户可以输入值，单元格引用/范围和数组的混合，并且该函数可以应对。例如outputArray() （你得到的图片）应该和{=PROBABLE(A1,5,B1:C15,IF(ISTEXT(D1:D3),LEN(D1:D3),0))}一样好用。我循环遍历inputArray（）的子元素并将它们放在我的outputArray（）中。我很确定这部分代码没什么问题。

然后，为了得到我的结果，我将UDF复制到=PROBABLE(A1:A3)，使用A1:A1000 或者代替计数1，我确实计算了每个可能的2,3,4等UDF输出并制作一个短宏来重新计算工作表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}输出{20%:0%:0%:80%}的图表，将每个百分比除以它的指数（20％/ 1,80％/ 4）和 Hey Presto {20%:0%:0%:20%}，或我预期的1：1比率。

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

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次测试。

Excel UDF加权RANDBETWEEN（）

更新

3 个答案: