Sulprobil
Search…
sbRandSum1
We present an example of a random number generation with a side condition. The sum of all created random numbers should be 1. This can be achieved by many different approaches.
Three possible approaches are: 1. Reduce grade of freedom successively: create first random number, then the second one in range[0,1-first), the third one in [0,1-first-second), ..., the last will be 1-sum of all others 2. Create n random numbers and divide them by their sum 3. Simulate slicing a cake: whereever you cut, you cannot distribute more than one cake
The resulting distributions look like:
You can see that the widely used simple approach to create n random numbers and then divide them by their sum is actually quite a poor choice: you mostly get numbers between 0.2 and 0.5 (see red line).
Please read my Disclaimer.
1
Function sbRandSum1(ByVal lDist As Long, _
2
Optional ByVal lCount As Long, _
3
Optional bVolatile As Boolean = False) As Variant
4
5
'sbRandSum1 produces lCount (or the number of selected cells if
6
'called from a worksheet range) random numbers which sum up to 1.
7
'Possible values of lDist to specify desired distribution:
8
' 1 = reduce degree of freedom linearly
9
' 2 = divide lCount random numbers by their sum
10
' 3 = lCount-1 random cuts of (0,1)-interval
11
'If TypeName(Application.Caller) <> "Range" Then lCount has to be set.
12
'It specifies the count of summands which have to have the sum of 1.
13
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbrandsum1
14
'(C) (P) Bernd Plumhoff V0.4 02-Aug-2020
15
Static bRandomized As Boolean
16
Dim bRowWise As Boolean
17
Dim vA As Variant, vT As Variant
18
Dim i As Long, j As Long
19
Dim dSum As Double
20
21
If bVolatile Then Application.Volatile
22
If Not bRandomized Then
23
Randomize
24
bRandomized = True
25
End If
26
If TypeName(Application.Caller) <> "Range" Then
27
If lCount < 1 Then
28
sbRandSum1 = CVErr(xlErrRef)
29
Exit Function
30
End If
31
bRowWise = False
32
Else
33
With Application.Caller
34
lCount = .Rows.Count
35
bRowWise = True
36
If lCount < .Columns.Count Then
37
lCount = .Columns.Count
38
bRowWise = False
39
End If
40
If lCount = 1 Then
41
sbRandSum1 = 1
42
Exit Function
43
End If
44
End With
45
End If
46
ReDim vA(1 To lCount) As Variant
47
Select Case lDist
48
Case 1
49
ReDim nRand(1 To lCount) As Long
50
For i = 1 To lCount
51
nRand(i) = i
52
Next i
53
For i = 1 To lCount - 1
54
j = Int(Rnd * (lCount - i + 1)) + i
55
vA(nRand(j)) = Rnd * (1# - dSum)
56
dSum = dSum + vA(nRand(j))
57
nRand(j) = nRand(i)
58
Next i
59
vA(nRand(lCount)) = 1# - dSum
60
Case 2
61
For i = 1 To lCount
62
vA(i) = Rnd
63
dSum = dSum + vA(i)
64
Next i
65
For i = 1 To lCount
66
vA(i) = vA(i) / dSum
67
Next i
68
Case 3
69
For i = 1 To lCount - 1
70
vA(i) = Rnd
71
j = i - 1
72
Do While j > 0
73
If vA(j) > vA(j + 1) Then
74
vT = vA(j + 1)
75
vA(j + 1) = vA(j)
76
vA(j) = vT
77
End If
78
j = j - 1
79
Loop
80
Next i
81
vA(lCount) = 1# - vA(lCount - 1)
82
i = lCount - 1
83
Do While i > 1
84
vA(i) = vA(i) - vA(i - 1)
85
i = i - 1
86
Loop
87
Case Else
88
sbRandSum1 = CVErr(xlErrValue)
89
Exit Function
90
End Select
91
If bRowWise Then vA = Application.WorksheetFunction.Transpose(vA)
92
sbRandSum1 = vA
93
End Function
Copied!
sbRandSum1.xlsm
31KB
Binary
Note: A more general approach would be using the Dirichlet distribution. For a Python implementation see numpy - for our task above you would need to set size to 1:
Last modified 1yr ago
Copy link