Sulprobil
Search…
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.
Please read my Disclaimer.
Function sbRandIntFixSum(lSum As Long, lMin As Long, _
lMax As Long, Optional lCount As Long = 0, _
Optional bUseRandTriang As Boolean = True, _
Optional bVolatile As Boolean = False) As Variant
'Returns lCount (or selected cell count in case a range is select) random
'integers between lMin and lMax which sum up to lSum.
'If bUseRandTriang the sbRandTriang distribution is used to "bias"
'the randomness to be "less extreme".
'Error values:
'#NUM! - No solution exists
'#VALUE! - lCount is less than 1
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbrandintfixsum
'V0.3 05-Aug-2020 (C) (P) by Bernd Plumhoff
Dim i As Long
Dim lRnd As Long, lMinPrev As Long
Dim lRow As Long, lCol As Long
With Application.Caller
If TypeName(Application.Caller) = "Range" And lCount = 0 Then
lCount = .Count
ReDim lR(1 To .Rows.Count, 1 To .Columns.Count) As Long
ElseIf lCount < 1 Then
sbRandIntFixSum = CVErr(xlErrValue)
Exit Function
Else
ReDim lR(1 To lCount, 1 To 1) As Long
End If
End With
Randomize
If bVolatile Then Application.Volatile
With Application.WorksheetFunction
For lRow = 1 To UBound(lR, 1)
For lCol = 1 To UBound(lR, 2)
lMinPrev = lMin
lMin = .RoundUp(.Max(lMin, .Min(lSum / lCount, lSum / lCount - (lCount - 1) * (lMax - lSum / lCount))), 0)
lMax = .RoundDown(.Min(lMax, .Max(lSum / lCount, lSum / lCount + (lCount - 1) * (lSum / lCount - lMinPrev))), 0)
If lMin > lMax Or lSum / lCount <> .Median(lMin, lMax, lSum / lCount) Then
'No solution exists
sbRandIntFixSum = CVErr(xlErrNum)
Exit Function
End If
If bUseRandTriang Then
If lMin = lMax Then
lRnd = lMin
Else
lRnd = Int(sbRandTriang(CDbl(lMin), lSum / lCount, CDbl(lMax)) + 0.5)
End If
Else
lRnd = Int(Rnd() * (lMax - lMin + 1) + lMin)
End If
lR(lRow, lCol) = lRnd
lSum = lSum - lRnd
lCount = lCount - 1
Next lCol
Next lRow
End With
sbRandIntFixSum = lR
End Function
sbRandIntFixSum.xlsm
26KB
Binary
sbRandIntFixSum.xlsm
Copy link