Create a histogram distribution of random numbers
Stratified sample of 1,000 runs
Please read my Disclaimer.
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.
'18-Oct-2020 V1.01 (C) (P) by Bernd Plumhoff
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()
dRand = dRandom
End If
dR = dSumWeight * dRand
i = n
Do While dR < dSumWeightI(i)
i = i - 1
sbRandHistogrm = dmin + (dMax - dmin) * _
(CDbl(i) + (dR - dSumWeightI(i)) / vW(i + 1)) / CDbl(n)
End Function
A real life example has arisen in an Excel newgroup: Create random unique groups of 5 books. This can be solved with sbRandHistoGrm:
The first 20 groups out of a total of 754:
Please read my Disclaimer.
Enum book_info_columns
bicNumber = 1
bicStats = 7
End Enum
Enum some_stats
statsCheck = 0
End Enum
Sub CreateGroups()
'Creates random groups of books with specified group size and specified number of books per title.
'Tries to use up all books.
'This sub needs (calls) UDF sbRandHistogrm.
'(C) (P) Bernd Plumhoff, v0.3 19-Oct-2020
Dim i As Long, j As Long, lBooks As Long, lGroups As Long, lSize As Long, lTotal As Long
Dim dMax As Double
Dim vI As Variant, vT As Variant
Dim state As SystemState
With Application.WorksheetFunction
Set state = New SystemState 'Speed up VBA
'First part - Read in book information and group size
vI = Range(wsI.Cells(2, bicNumber), wsI.Cells(1, bicTitle).End(xlDown))
lSize = Range("GroupSize")
'Second part - Create groups
lBooks = UBound(vI, 1)
lTotal = .Sum(.Index(.Transpose(vI), bicCount))
ReDim lOut(1 To lSize, 1 To lTotal \ lSize) As Long
ReDim lStats(1 To lBooks, 0 To statsUBound - 1) As Long
Do While CountNonZero(vI) >= lSize 'As long as we can fill a group we continue
lGroups = lGroups + 1
dMax = .Max(.Index(.Transpose(vI), bicCount))
vT = .Index(.Transpose(vI), bicCount)
For i = LBound(vT) To UBound(vT)
'Exponentially scaled weights are better than linear ones
If vT(i) > 0# Then vT(i) = Exp(vT(i) / dMax * 5#) 'Change 5# if necessary
Next i
For i = 1 To lSize
j = Int(sbRandHistogrm(1#, CDbl(lBooks) + 1#, vT))
vT(j) = 0 'This book must not reappear in this group
lOut(i, lGroups) = j
vI(j, bicCount) = vI(j, bicCount) - 1
lStats(j, statsCheck) = lStats(j, statsCheck) + 1
lStats(j, statsAvgGroup) = lStats(j, statsAvgGroup) + lGroups
If lStats(j, statsMinGroup) = 0 Then lStats(j, statsMinGroup) = lGroups
lStats(j, statsMaxGroup) = lGroups
Next i
If lGroups = 0 Then
Call MsgBox("No group. Number of books is too small or size of groups too large.", vbOKOnly, "Error")
Exit Sub
End If
ReDim Preserve lOut(1 To lSize, 1 To lGroups) As Long
'Third part - Fill output sheet
Range(wsO.Cells(1, 1), wsO.Cells(lGroups, lSize)).FormulaArray = .Transpose(lOut)
'Fourth part - some statistics to reassure the user that we got a good mix and used up as many books as possible
For i = 1 To lBooks
lStats(i, statsRest) = vI(i, bicCount)
lStats(i, statsAvgGroup) = lStats(i, statsAvgGroup) \ lStats(i, statsCheck)
Next i
Range("GroupsGenerated") = lGroups
Range(wsI.Cells(2, bicStats + statsCheck), wsI.Cells(1 + lBooks, bicStats + statsUBound - 1)).FormulaArray = lStats
Set state = Nothing 'Not even necessary - will be done automatically
End With
End Sub
Function CountNonZero(v As Variant) As Long
Dim i As Long, n As Long
For i = LBound(v, 1) To UBound(v, 1)
If v(i, bicCount) <> 0 Then n = n + 1
Next i
CountNonZero = n
End Function