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

26KB

sbRandIntFixSum.xlsm