Excel UDF 加权 RANDBETWEEN()
Excel UDF weighted RANDBETWEEN()
其实不是 RANDBETWEEN()。我正在尝试创建一个 UDF 以 return 数组中数字的索引，其中数字越大，被选中的可能性就越大。
我知道如何将概率分配给工作中的随机数sheet（即对概率总和使用 MATCH()，SO 上有很多内容对此进行了解释），但我想要一个 UDF，因为我将一个特殊的输入数组传递给函数——而不仅仅是一个选定的范围。
我的问题是，权重已关闭，数组中后面的数字比数组中前面的数字更有可能被 returned，我看不到我的代码中的哪个位置出错了。到目前为止，这是 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 在数组被 returned，我得到了这个结果：
大约 20%:80% 分布。绘图 {1,1,1,1}（所有人都应该有平等的机会）给出了 10%:20%:30%:40% 的分布
我知道我遗漏了一些明显的东西，但我不知道是什么，有什么帮助吗？
更新
有些人要完整的代码，就在这里。
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()段用于规范不同的输入法。 IE。用户可以混合输入值、单元格 references/ranges 和数组，该函数可以应付。例如{=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，而是计数 2、3、4 等每个可能的 UDF 输出 并制作了一个简短的宏来重新计算 sheet 100 次，每次将 countif 的结果复制到 table 中以进行绘图。我不能准确地说出我是怎么做到的，因为我把这一切都留在了工作中，但我会在周一更新。
这是我按照你的逻辑建造的东西。它工作得很好，提供了不同的结果。
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 次测试。
试试这个：
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} 和 return 1, 2, 3 or 4 中的任何一个。
另请注意：如果将 Application.Sum(v) 的值保存在变量中而不是对数组 v.[=26= 中的每个值执行计算，则可能会更快一些]
更新
该函数现在将 v 作为参数——就像您的代码一样。我还对其进行了一些调整，以便它可以处理具有任何基数的 v，这意味着您也可以从工作表中 运行 它：例如 =Probable({1,0,0,1})
看来我犯了一个悲惨的错误。我的代码很好，我的计数不太好。我在我的图形中使用 SUMIF() 而不是 COUNTIF()，导致数组中后来的对象（具有更高的 Index - 我是 UDF 的输出应该计算但不是求和）得到与其位置成比例的权重。
回想起来，我认为比我聪明得多的人可能已经从所提供的信息中推断出这一点。我说{1,1,1,1}有一个{10%:20%:30%:40%}，也就是{1:2:3:4}的比例，刚好和outputs的index是一样的，推导：outputs是相加不计算的。
类似地，具有 {20%:0%:0%:80%} 输出的 {1,0,0,1} 图表，我们将每个百分比除以它的索引 (20%/1, 80%/4) 和 嘿 Presto {20%:0%:0%:20%}，或者我预期的 1:1 比率。
有些烦人但令人满意 - 知道答案一直就在那里。我想这一切可能都有道理。至少 post 可以作为一个警告，提醒初出茅庐的 VBA 人检查他们的算法。
其实不是 RANDBETWEEN()。我正在尝试创建一个 UDF 以 return 数组中数字的索引，其中数字越大，被选中的可能性就越大。
我知道如何将概率分配给工作中的随机数sheet（即对概率总和使用 MATCH()，SO 上有很多内容对此进行了解释），但我想要一个 UDF，因为我将一个特殊的输入数组传递给函数——而不仅仅是一个选定的范围。
我的问题是，权重已关闭，数组中后面的数字比数组中前面的数字更有可能被 returned，我看不到我的代码中的哪个位置出错了。到目前为止，这是 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 在数组被 returned，我得到了这个结果：
大约 20%:80% 分布。绘图 {1,1,1,1}（所有人都应该有平等的机会）给出了 10%:20%:30%:40% 的分布
我知道我遗漏了一些明显的东西，但我不知道是什么，有什么帮助吗？
更新
有些人要完整的代码，就在这里。
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()段用于规范不同的输入法。 IE。用户可以混合输入值、单元格 references/ranges 和数组，该函数可以应付。例如{=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，而是计数 2、3、4 等每个可能的 UDF 输出 并制作了一个简短的宏来重新计算 sheet 100 次，每次将 countif 的结果复制到 table 中以进行绘图。我不能准确地说出我是怎么做到的，因为我把这一切都留在了工作中，但我会在周一更新。
这是我按照你的逻辑建造的东西。它工作得很好，提供了不同的结果。
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 次测试。
试试这个：
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} 和 return 1, 2, 3 or 4 中的任何一个。
另请注意：如果将 Application.Sum(v) 的值保存在变量中而不是对数组 v.[=26= 中的每个值执行计算，则可能会更快一些]
更新
该函数现在将 v 作为参数——就像您的代码一样。我还对其进行了一些调整，以便它可以处理具有任何基数的 v，这意味着您也可以从工作表中 运行 它：例如 =Probable({1,0,0,1})
看来我犯了一个悲惨的错误。我的代码很好，我的计数不太好。我在我的图形中使用 SUMIF() 而不是 COUNTIF()，导致数组中后来的对象（具有更高的 Index - 我是 UDF 的输出应该计算但不是求和）得到与其位置成比例的权重。
回想起来，我认为比我聪明得多的人可能已经从所提供的信息中推断出这一点。我说{1,1,1,1}有一个{10%:20%:30%:40%}，也就是{1:2:3:4}的比例，刚好和outputs的index是一样的，推导：outputs是相加不计算的。
类似地，具有 {20%:0%:0%:80%} 输出的 {1,0,0,1} 图表，我们将每个百分比除以它的索引 (20%/1, 80%/4) 和 嘿 Presto {20%:0%:0%:20%}，或者我预期的 1:1 比率。
有些烦人但令人满意 - 知道答案一直就在那里。我想这一切可能都有道理。至少 post 可以作为一个警告，提醒初出茅庐的 VBA 人检查他们的算法。