I am a supporter of
St. Joseph's hospice.
 If you find this site useful or if it helped you, consider a small donation to
St. Joseph's, please.

Information on
St. Joseph's

JustGiving - Sponsor me now!

 

sbExactRandHistogrm

It is fairly easy to create a loaded die, let us say on average the 6 should appear twice as often as all the other numbers 1 thru 5: Enter into A1: =MIN(INT(RAND()*7+1),6)

But what if you want to create 7 rolls of this die and all numbers between 1 and 5 should appear exactly once and 6 exactly twice?

Here is my general solution:

sbExactRandHistogrm_01_Screen

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 21-Sep-2019 (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

Other, but similar methods are shown at D’Hondt Method and at sbRoundToSum.

If you are interested in downloading a 29 KB Excel 2010 © sample file go to my download page, please.

Sulprobil   Get it done   Contact   Disclaimer   Impressum   Download