sbRandHistogrm

Create a histogram distribution of random numbers

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
'Source: https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbrandhistogrm

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()
Else
    dRand = dRandom
End If
dR = dSumWeight * dRand

i = n
Do While dR < dSumWeightI(i)
    i = i - 1
Loop

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
    bicCount
    bicTitle
    bicStats = 7
End Enum

Enum some_stats
    statsCheck = 0
    statsRest
    statsMinGroup
    statsAvgGroup
    statsMaxGroup
    statsUBound
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
'Source: https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbrandhistogrm
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
'See https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/classes/systemstate
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
Randomize
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
        'See https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbrandhistogrm
        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
Loop
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
wsO.Cells.ClearContents
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
PrevioussbRandGeneralNextsbRandInt

Last updated