sbRandHistogrm
Create a histogram distribution of random numbers
Stratified sample of 1,000 runs
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:
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
sbRandHistogrm.xlsm
105KB
Binary
Last modified 2yr ago