sbExactRandInt - Create an exact integer histogram distribution.
Synopsis
sbExactRandInt(vWeight, lDraws)
Description
sbExactRandInt creates Creates an exact histogram distribution for integers (type Long) of vWeight.count draws. vWeight(i) reflects the probability of the occurrence of i. If these weights can't be achieved exactly then the largest remainder method will be applied to minimize the absolute error. If not called as a worksheet function (i.e. via VBA), argument lDraws has to be provided.
This function calls (needs) sbRoundToSum.
Options
vWeight
Array of weights. Array size determines the number of different classes the range dmin : dmax is divided into. Values in this array specify likelihood of this class' numbers to appear (be drawn).
lDraws
Optional - Number of draws. This argument has only to be provided if this function is not called as a worksheet function.
Function sbExactRandInt(vWeight As Variant, Optional lDraws As Long = 0) As Variant
'Creates an exact histogram distribution for vWeight.count draws.
'vWeight(i) reflects the probability of the occurrence of i.
'If these weights can't be achieved exactly then the largest remainder method will
'be applied to minimize the absolute error. This function calls (needs) sbRoundToSum.
'If not called as a worksheet function (i.e. via VBA), argument lDraws has to be provided.
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbexactrandint
'PB V0.1 02-May-2021 (C) (P) by Bernd Plumhoff
Static bRandomized As Boolean
Dim i As Long, j As Long, n As Long, lD As Long
Dim vW As Variant
Dim dSumWeight As Double, dR As Double
If Not bRandomized Then
Randomize
bRandomized = True
End If
With Application.WorksheetFunction
vW = .Transpose(vWeight)
On Error GoTo Errhdl
i = vW(1) 'Throw error in case of horizontal array
On Error GoTo 0
n = UBound(vW)
lD = lDraws
If TypeName(Application.Caller) = "Range" Then
'If called as a worksheet function then the number of selected output cells
'must equal the number of elements in vWeight and the cell selection must
'be 1 row or 1 column.
lD = Application.Caller.Count
If Application.Caller.Rows.Count <> 1 And Application.Caller.Columns.Count <> 1 Then
sbExactRandInt = CVErr(xlErrValue)
Exit Function
End If
End If
If lD < 1 Then
sbExactRandInt = CVErr(xlErrNum)
Exit Function
End If
ReDim dWeight(1 To n) As Double
ReDim dSumWeightI(0 To n) As Double
ReDim vR(1 To lD) As Variant
For i = 1 To n
If vW(i) < 0# Then 'A negative weight is an error
sbExactRandInt = CVErr(xlErrValue)
Exit Function
End If
'Calculate sum of all weights
dSumWeight = dSumWeight + vW(i)
Next i
If dSumWeight = 0# Then
'Sum of weights has to be greater zero
sbExactRandInt = CVErr(xlErrValue)
Exit Function
End If
For i = 1 To n
'Align weights to number of draws
dWeight(i) = CDbl(lD) * vW(i) / dSumWeight
Next i
vW = sbRoundToSum(dWeight, 0)
On Error GoTo Errhdl
i = vW(1) 'Throw error in case of horizontal array
On Error GoTo 0
For j = 1 To lD
dSumWeight = 0#
dSumWeightI(0) = 0#
For i = 1 To n
'Calculate sum of all weights
dSumWeight = dSumWeight + vW(i)
'Calculate sum of weights till i
dSumWeightI(i) = dSumWeight
Next i
dR = dSumWeight * Rnd
i = n
Do While dR < dSumWeightI(i)
i = i - 1
Loop
vR(j) = i + 1
vW(i + 1) = vW(i + 1) - 1#
Next j
sbExactRandInt = vR
Exit Function
Errhdl:
'Transpose variants to be able to address
'them with vW(i), not vW(i,1)
vW = .Transpose(vW)
Resume Next
End With
End Function
Sub Test_sbExactRandInt()
Dim v As Variant, i As Long, j As Long
For i = 1 To 10
v = sbExactRandInt(Array(3, 2, 1), 6)
For j = 1 To 6
Debug.Print v(j);
Next j
Debug.Print
Next i
End Sub
