**“Chance favours the prepared mind.” [Louis Pasteur]**

## Abstract

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:

## The Excel / VBA Function sbExactRandHistogrm

### Name

*sbExactRandHistogrm* – Create an exact **double** histogram distribution.

### Synopsis

*sbExactRandHistogrm*(*ldraw*, *dmin*, *dmax*, *vWeight*)

### Description

*sbExactRandHistogrm* creates an exact histogram distribution for *ldraw* draws
of floating point numbers with double precision 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 the absolute error.
This function calls (needs) RoundToSum.

### Parameters

*ldraw* – Number of draws

*dmin* – Minimum = lower boundary of range of numbers to draw

*dmax* – Maximum = upper boundary of range of numbers to draw

*vWeight* – Array of weights. Array size determines the number of different classes the range *dmin : dmax* is divided into.
Values in this array specify likelihood of this class' numbers to appear (be drawn).

## See Also

## Appendix – sbRandHistogrm Code

Please note: this function refers to (needs) RoundToSum.

Please read my Disclaimer.

```
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 the absolute error. This function calls (needs) sbRoundToSum.
'Source (EN): http://www.sulprobil.com/sbexactrandhistogrm_en/
'Source (DE): http://www.bplumhoff.de/sbexactrandhistogrm_de/
'(C) (P) by Bernd Plumhoff 01-May-2021 PB V0.9
Dim i As Long, j As Long, n As Long
Dim vW As Variant
Dim dSumWeight As Double, dR As Double
Randomize
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
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 = RoundToSum(dWeight, 0)
On Error GoTo Errhdl
i = vW(1) 'Throw error in case of horizontal array
On Error GoTo 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
```