Sulprobil
Search…
sbExactRandInt
Name
sbExactRandInt - Create an exact integer histogram distribution.
Synopsis
sbExactRandInt(vWeight, lDraws)
Description
sbExactRandInt creates Creates an exact histogram distribution for integers (type Long) of vWeight.count draws. vWeight(i) reflects the probability of the occurrence of i. If these weights can't be achieved exactly then the largest remainder method will be applied to minimize the absolute error. If not called as a worksheet function (i.e. via VBA), argument lDraws has to be provided.
This function calls (needs) sbRoundToSum.
Options
vWeight
Array of weights. Array size determines the number of different classes the range dmin : dmax is divided into. Values in this array specify likelihood of this class' numbers to appear (be drawn).
lDraws
Optional - Number of draws. This argument has only to be provided if this function is not called as a worksheet function.
See Also
1
Function sbExactRandInt(vWeight As Variant, Optional lDraws As Long = 0) As Variant
2
'Creates an exact histogram distribution for vWeight.count draws.
3
'vWeight(i) reflects the probability of the occurrence of i.
4
'If these weights can't be achieved exactly then the largest remainder method will
5
'be applied to minimize the absolute error. This function calls (needs) sbRoundToSum.
6
'If not called as a worksheet function (i.e. via VBA), argument lDraws has to be provided.
7
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbexactrandint
8
'PB V0.1 02-May-2021 (C) (P) by Bernd Plumhoff
9
​
10
Static bRandomized As Boolean
11
Dim i As Long, j As Long, n As Long, lD As Long
12
Dim vW As Variant
13
Dim dSumWeight As Double, dR As Double
14
​
15
If Not bRandomized Then
16
Randomize
17
bRandomized = True
18
End If
19
​
20
With Application.WorksheetFunction
21
​
22
vW = .Transpose(vWeight)
23
On Error GoTo Errhdl
24
i = vW(1) 'Throw error in case of horizontal array
25
On Error GoTo 0
26
​
27
n = UBound(vW)
28
lD = lDraws
29
If TypeName(Application.Caller) = "Range" Then
30
'If called as a worksheet function then the number of selected output cells
31
'must equal the number of elements in vWeight and the cell selection must
32
'be 1 row or 1 column.
33
lD = Application.Caller.Count
34
If Application.Caller.Rows.Count <> 1 And Application.Caller.Columns.Count <> 1 Then
35
sbExactRandInt = CVErr(xlErrValue)
36
Exit Function
37
End If
38
End If
39
If lD < 1 Then
40
sbExactRandInt = CVErr(xlErrNum)
41
Exit Function
42
End If
43
​
44
ReDim dWeight(1 To n) As Double
45
ReDim dSumWeightI(0 To n) As Double
46
ReDim vR(1 To lD) As Variant
47
​
48
For i = 1 To n
49
If vW(i) < 0# Then 'A negative weight is an error
50
sbExactRandInt = CVErr(xlErrValue)
51
Exit Function
52
End If
53
'Calculate sum of all weights
54
dSumWeight = dSumWeight + vW(i)
55
Next i
56
​
57
If dSumWeight = 0# Then
58
'Sum of weights has to be greater zero
59
sbExactRandInt = CVErr(xlErrValue)
60
Exit Function
61
End If
62
​
63
For i = 1 To n
64
'Align weights to number of draws
65
dWeight(i) = CDbl(lD) * vW(i) / dSumWeight
66
Next i
67
​
68
vW = sbRoundToSum(dWeight, 0)
69
On Error GoTo Errhdl
70
i = vW(1) 'Throw error in case of horizontal array
71
On Error GoTo 0
72
​
73
For j = 1 To lD
74
dSumWeight = 0#
75
dSumWeightI(0) = 0#
76
For i = 1 To n
77
'Calculate sum of all weights
78
dSumWeight = dSumWeight + vW(i)
79
'Calculate sum of weights till i
80
dSumWeightI(i) = dSumWeight
81
Next i
82
dR = dSumWeight * Rnd
83
i = n
84
Do While dR < dSumWeightI(i)
85
i = i - 1
86
Loop
87
vR(j) = i + 1
88
vW(i + 1) = vW(i + 1) - 1#
89
Next j
90
​
91
sbExactRandInt = vR
92
​
93
Exit Function
94
​
95
Errhdl:
96
'Transpose variants to be able to address
97
'them with vW(i), not vW(i,1)
98
vW = .Transpose(vW)
99
Resume Next
100
End With
101
​
102
End Function
103
​
104
Sub Test_sbExactRandInt()
105
Dim v As Variant, i As Long, j As Long
106
For i = 1 To 10
107
v = sbExactRandInt(Array(3, 2, 1), 6)
108
For j = 1 To 6
109
Debug.Print v(j);
110
Next j
111
Debug.Print
112
Next i
113
End Sub
Copied!
sbExactRandInt.xlsm
36KB
Binary
sbExactRandInt.xlsm
Last modified 6mo ago
Copy link