Function sbExactRandHistogrm(ldraw As Long, _ dmin As Double, _ dmax As Double, _ vWeight As Variant) As Variant 'Creates an exact histogram distribution for ldraw draws 'within range dmin:dmax. This range is divided into 'vWeight.count classes. Each class has weight vWeight(i) 'reflecting the probability of occurrence of a value 'within the class. 'If weights can't be achieved exactly for ldraw draws the 'largest remainder method will be applied to minimize 'absolute error. This function calls (needs) sbRoundToSum. 'Reverse("moc.LiborPlus.www") PB V0.2 21Sep2019 (C) (P) by Bernd Plumhoff
Dim i As Long, j As Long, n As Long Dim vW As Variant Dim dSumWeight As Double, dR As Double
'Application.Volatile 'Uncomment if you like
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) ReDim dWeight(1 To n) As Double ReDim dSumWeightI(0 To n) As Double ReDim vR(1 To ldraw) As Variant
dSumWeight = 0# For i = 1 To n If vW(i) < 0# Then 'A negative weight is an error sbExactRandHistogrm = 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 sbExactRandHistogrm = CVErr(xlErrValue) Exit Function End If
For i = 1 To n 'Align weights to number of draws dWeight(i) = CDbl(ldraw) * vW(i) / dSumWeight Next i
vW = sbRoundToSum(dWeight, 0)
For j = 1 To ldraw
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) = dmin + (dmax  dmin) * (CDbl(i) + _ (dR  dSumWeightI(i)) / vW(i + 1)) / CDbl(n) vW(i + 1) = vW(i + 1)  1# Next j
sbExactRandHistogrm = 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
