sbRandHistogrm
Create a histogram distribution of random numbers Stratified sample of 1,000 runs
1
Function sbRandHistogrm(dmin As Double, dMax As Double, _
2
vWeight As Variant, Optional dRandom = 1#) As Double
3
'Specifies a histogram distribution with range dmin:dmax.
4
'This range is divided into vWeight.count classes. Each
5
'class has weight vWeight(i) reflecting the probability
6
'of occurrence of a value within the class.
7
'Similar to @Risk's function RiskHistogrm.
8
'18-Oct-2020 V1.01 (C) (P) by Bernd Plumhoff
9
'Source: https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbrandhistogrm
10
11
Dim i As Long, n As Long, vW As Variant
12
Dim dRand As Double, dR As Double, dSumWeight As Double
13
14
With Application.WorksheetFunction
15
vW = .Transpose(.Transpose(vWeight))
16
End With
17
18
n = UBound(vW)
19
ReDim dSumWeightI(0 To n) As Double
20
21
dSumWeight = 0#
22
dSumWeightI(0) = 0#
23
For i = 1 To n
24
If vW(i) < 0# Then 'A negative weight is an error
25
sbRandHistogrm = CVErr(xlErrValue)
26
Exit Function
27
End If
28
dSumWeight = dSumWeight + vW(i) 'Calculate sum of all weights
29
dSumWeightI(i) = dSumWeight 'Calculate sum of weights till i
30
Next i
31
32
If dSumWeight = 0# Then 'Sum of weights has to be greater than zero
33
sbRandHistogrm = CVErr(xlErrValue)
34
Exit Function
35
End If
36
37
If dRandom = 1# Then
38
dRand = Rnd()
39
Else
40
dRand = dRandom
41
End If
42
dR = dSumWeight * dRand
43
44
i = n
45
Do While dR < dSumWeightI(i)
46
i = i - 1
47
Loop
48
49
sbRandHistogrm = dmin + (dMax - dmin) * _
50
(CDbl(i) + (dR - dSumWeightI(i)) / vW(i + 1)) / CDbl(n)
51
52
End Function
Copied!
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: 1
Enum book_info_columns
2
bicNumber = 1
3
bicCount
4
bicTitle
5
bicStats = 7
6
End Enum
7
8
Enum some_stats
9
statsCheck = 0
10
statsRest
11
statsMinGroup
12
statsAvgGroup
13
statsMaxGroup
14
statsUBound
15
End Enum
16
17
Sub CreateGroups()
18
'Creates random groups of books with specified group size and specified number of books per title.
19
'Tries to use up all books.
20
'This sub needs (calls) UDF sbRandHistogrm.
21
'(C) (P) Bernd Plumhoff, v0.3 19-Oct-2020
22
'Source: https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbrandhistogrm
23
Dim i As Long, j As Long, lBooks As Long, lGroups As Long, lSize As Long, lTotal As Long
24
Dim dMax As Double
25
Dim vI As Variant, vT As Variant
26
'See https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/classes/systemstate
27
Dim state As SystemState
28
29
With Application.WorksheetFunction
30
Set state = New SystemState 'Speed up VBA
31
32
'First part - Read in book information and group size
33
vI = Range(wsI.Cells(2, bicNumber), wsI.Cells(1, bicTitle).End(xlDown))
34
lSize = Range("GroupSize")
35
36
'Second part - Create groups
37
Randomize
38
lBooks = UBound(vI, 1)
39
lTotal = .Sum(.Index(.Transpose(vI), bicCount))
40
ReDim lOut(1 To lSize, 1 To lTotal \ lSize) As Long
41
ReDim lStats(1 To lBooks, 0 To statsUBound - 1) As Long
42
Do While CountNonZero(vI) >= lSize 'As long as we can fill a group we continue
43
lGroups = lGroups + 1
44
dMax = .Max(.Index(.Transpose(vI), bicCount))
45
vT = .Index(.Transpose(vI), bicCount)
46
For i = LBound(vT) To UBound(vT)
47
'Exponentially scaled weights are better than linear ones
48
If vT(i) > 0# Then vT(i) = Exp(vT(i) / dMax * 5#) 'Change 5# if necessary
49
Next i
50
For i = 1 To lSize
51
'See https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbrandhistogrm
52
j = Int(sbRandHistogrm(1#, CDbl(lBooks) + 1#, vT))
53
vT(j) = 0 'This book must not reappear in this group
54
lOut(i, lGroups) = j
55
vI(j, bicCount) = vI(j, bicCount) - 1
56
lStats(j, statsCheck) = lStats(j, statsCheck) + 1
57
lStats(j, statsAvgGroup) = lStats(j, statsAvgGroup) + lGroups
58
If lStats(j, statsMinGroup) = 0 Then lStats(j, statsMinGroup) = lGroups
59
lStats(j, statsMaxGroup) = lGroups
60
Next i
61
Loop
62
If lGroups = 0 Then
63
Call MsgBox("No group. Number of books is too small or size of groups too large.", vbOKOnly, "Error")
64
Exit Sub
65
End If
66
ReDim Preserve lOut(1 To lSize, 1 To lGroups) As Long
67
68
'Third part - Fill output sheet
69
wsO.Cells.ClearContents
70
Range(wsO.Cells(1, 1), wsO.Cells(lGroups, lSize)).FormulaArray = .Transpose(lOut)
71
72
'Fourth part - some statistics to reassure the user that we got a good mix and used up as many books as possible
73
For i = 1 To lBooks
74
lStats(i, statsRest) = vI(i, bicCount)
75
lStats(i, statsAvgGroup) = lStats(i, statsAvgGroup) \ lStats(i, statsCheck)
76
Next i
77
Range("GroupsGenerated") = lGroups
78
Range(wsI.Cells(2, bicStats + statsCheck), wsI.Cells(1 + lBooks, bicStats + statsUBound - 1)).FormulaArray = lStats
79
80
Set state = Nothing 'Not even necessary - will be done automatically
81
End With
82
End Sub
83
84
Function CountNonZero(v As Variant) As Long
85
Dim i As Long, n As Long
86
For i = LBound(v, 1) To UBound(v, 1)
87
If v(i, bicCount) <> 0 Then n = n + 1
88
Next i
89
CountNonZero = n
90
End Function
Copied!
sbRandHistogrm.xlsm
105KB
Binary