Sulprobil
Search…
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
Last modified 1yr ago
Copy link