“Chance favours the prepared mind.” [Louis Pasteur]
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
sbExactRandHistogrm – Create an exact double histogram distribution.
sbExactRandHistogrm(ldraw, dmin, dmax, vWeight)
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.
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).
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
Please read my Disclaimer.
sbExactRandHistoGrm.xlsm [32 KB Excel file, open and use at your own risk]