sbRandIntFixSum
You want to create lCount random integers between a lower boundary lMin and an upper boundary lMax, and they need to sum up to exactly lSum?
This function is similar to sbLongRandSumN.
Please note that you need to include the program sbRandTriang.
1
Function sbRandIntFixSum(lSum As Long, lMin As Long, _
2
lMax As Long, Optional lCount As Long = 0, _
3
Optional bUseRandTriang As Boolean = True, _
4
Optional bVolatile As Boolean = False) As Variant
5
'Returns lCount (or selected cell count in case a range is select) random
6
'integers between lMin and lMax which sum up to lSum.
7
'If bUseRandTriang the sbRandTriang distribution is used to "bias"
8
'the randomness to be "less extreme".
9
10
'Error values:
11
'#NUM! - No solution exists
12
'#VALUE! - lCount is less than 1
13
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbrandintfixsum
14
'V0.3 05-Aug-2020 (C) (P) by Bernd Plumhoff
15
16
Dim i As Long
17
Dim lRnd As Long, lMinPrev As Long
18
Dim lRow As Long, lCol As Long
19
20
With Application.Caller
21
If TypeName(Application.Caller) = "Range" And lCount = 0 Then
22
lCount = .Count
23
ReDim lR(1 To .Rows.Count, 1 To .Columns.Count) As Long
24
ElseIf lCount < 1 Then
25
sbRandIntFixSum = CVErr(xlErrValue)
26
Exit Function
27
Else
28
ReDim lR(1 To lCount, 1 To 1) As Long
29
End If
30
End With
31
32
Randomize
33
If bVolatile Then Application.Volatile
34
35
With Application.WorksheetFunction
36
For lRow = 1 To UBound(lR, 1)
37
For lCol = 1 To UBound(lR, 2)
38
lMinPrev = lMin
39
lMin = .RoundUp(.Max(lMin, .Min(lSum / lCount, lSum / lCount - (lCount - 1) * (lMax - lSum / lCount))), 0)
40
lMax = .RoundDown(.Min(lMax, .Max(lSum / lCount, lSum / lCount + (lCount - 1) * (lSum / lCount - lMinPrev))), 0)
41
If lMin > lMax Or lSum / lCount <> .Median(lMin, lMax, lSum / lCount) Then
42
'No solution exists
43
sbRandIntFixSum = CVErr(xlErrNum)
44
Exit Function
45
End If
46
If bUseRandTriang Then
47
If lMin = lMax Then
48
lRnd = lMin
49
Else
50
lRnd = Int(sbRandTriang(CDbl(lMin), lSum / lCount, CDbl(lMax)) + 0.5)
51
End If
52
Else
53
lRnd = Int(Rnd() * (lMax - lMin + 1) + lMin)
54
End If
55
lR(lRow, lCol) = lRnd
56
lSum = lSum - lRnd
57
lCount = lCount - 1
58
Next lCol
59
Next lRow
60
End With
61
62
sbRandIntFixSum = lR
63
64
End Function
Copied!
sbRandIntFixSum.xlsm
26KB
Binary
sbRandIntFixSum.xlsm