sbExactRandInt

Name
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.
See Also
​sbExactRandHistoGrm
sbRoundToSum
sbRandHistogrm​
Please read my Disclaimer.
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
sbExactRandInt.xlsm
36KB
Binary
sbExactRandInt.xlsm

sbExactRandHistogrm

sbExportRange2Picture

Last modified 1yr ago

Copy link