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 dSumWeight As Double, dR As Double
With Application.WorksheetFunction
i = vW(1) 'Throw error in case of horizontal array
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
lD = Application.Caller.Count
If Application.Caller.Rows.Count <> 1 And Application.Caller.Columns.Count <> 1 Then
sbExactRandInt = CVErr(xlErrValue)
sbExactRandInt = CVErr(xlErrNum)
ReDim dWeight(1 To n) As Double
ReDim dSumWeightI(0 To n) As Double
ReDim vR(1 To lD) As Variant
If vW(i) < 0# Then 'A negative weight is an error
sbExactRandInt = CVErr(xlErrValue)
'Calculate sum of all weights
dSumWeight = dSumWeight + vW(i)
'Sum of weights has to be greater zero
sbExactRandInt = CVErr(xlErrValue)
'Align weights to number of draws
dWeight(i) = CDbl(lD) * vW(i) / dSumWeight
vW = sbRoundToSum(dWeight, 0)
i = vW(1) 'Throw error in case of horizontal array
'Calculate sum of all weights
dSumWeight = dSumWeight + vW(i)
'Calculate sum of weights till i
dSumWeightI(i) = dSumWeight
Do While dR < dSumWeightI(i)
vW(i + 1) = vW(i + 1) - 1#
'Transpose variants to be able to address
'them with vW(i), not vW(i,1)
Sub Test_sbExactRandInt()
Dim v As Variant, i As Long, j As Long
v = sbExactRandInt(Array(3, 2, 1), 6)