Abstract
Appendix Programmcode sbRandHistogrm
Bitte den Haftungsausschluss im Impressum beachten.
Function sbRandHistogrm(dmin As Double, dMax As Double, _
vWeight As Variant, Optional dRandom = 1#) As Double
'Specifies a histogram distribution with 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.
'Similar to @Risk's function RiskHistogrm.
'Source (EN): http://www.sulprobil.de/sbrandhistogrm_en/
'Source (DE): http://www.berndplumhoff.de/sbrandhistogrm_de/
'(C) (P) by Bernd Plumhoff 18-Oct-2020 PB V1.01
Dim i As Long, n As Long, vW As Variant
Dim dRand As Double, dR As Double, dSumWeight As Double
With Application.WorksheetFunction
vW = .Transpose(.Transpose(vWeight))
End With
n = UBound(vW)
ReDim dSumWeightI(0 To n) As Double
dSumWeight = 0#
dSumWeightI(0) = 0#
For i = 1 To n
If vW(i) < 0# Then 'A negative weight is an error
sbRandHistogrm = CVErr(xlErrValue)
Exit Function
End If
dSumWeight = dSumWeight + vW(i) 'Calculate sum of all weights
dSumWeightI(i) = dSumWeight 'Calculate sum of weights till i
Next i
If dSumWeight = 0# Then 'Sum of weights has to be greater than zero
sbRandHistogrm = CVErr(xlErrValue)
Exit Function
End If
If dRandom = 1# Then
dRand = Rnd()
Else
dRand = dRandom
End If
dR = dSumWeight * dRand
i = n
Do While dR < dSumWeightI(i)
i = i - 1
Loop
sbRandHistogrm = dmin + (dMax - dmin) * _
(CDbl(i) + (dR - dSumWeightI(i)) / vW(i + 1)) / CDbl(n)
End Function
Bitte den Haftungsausschluss im Impressum beachten.
sbRandHistogrm.xlsm [99 KB Excel Datei, ohne jegliche Gewährleistung]