ExactRandHistogrm

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

ExactRandHistogrm

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:

Function ExactRandHistogrm(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):
'LRM - http://sulprobil.com/html/largest_remainder.html
'Reverse(moc.LiborPlus.www) V0.10 19-Dec-2009

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
        ExactRandHistogrm = CVErr(xlErrValue)
        Exit Function
    End If
    dSumWeight = dSumWeight + vW(i) 'Calculate sum of all weights
Next i

If dSumWeight = 0# Then 'Sum of weights has to be greater zero
    ExactRandHistogrm = CVErr(xlErrValue)
    Exit Function
End If

For i = 1 To n
    dWeight(i) = CDbl(ldraw) * vW(i) / _
                      dSumWeight 'Align weights to number of draws
Next i

vW = LRM("A", 0, dWeight)

For j = 1 To ldraw

    dSumWeight = 0#
    dSumWeightI(0) = 0#
    For i = 1 To n
        dSumWeight = dSumWeight + vW(i) 'Calculate sum of all weights
        dSumWeightI(i) = dSumWeight     'Calculate sum of weights till i
    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

ExactRandHistogrm = 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

[Sulprobil] [Get it done] [Organisation] [IT] [Controlling] [Human Resources] [Family] [Contact] [Download] [Disclaimer]