Option Explicit

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 when
'called as a matrix formula) 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
'Source (EN): http://www.sulprobil.com/sbrandintfixsum_en/
'Source (DE): http://www.bplumhoff.de/sbrandintfixsum_de/
'(C) (P) by Bernd Plumhoff 05-Aug-2020 PB V0.3

Dim i As Long
Dim lRnd As Long, lMinPrev As Long
Dim lRow As Long, lCol As Long

With Application

If TypeName(.Caller) = "Range" And lCount = 0 Then
    lCount = .Caller.Count
    ReDim lR(1 To .Caller.Rows.Count, 1 To .Caller.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

Randomize
If bVolatile Then .Volatile

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

sbRandIntFixSum = lR
End With

End Function

Sub GenerateRandIntFixSum()
[E7:E27].FormulaArray = sbRandIntFixSum([B1], [B2], [B3], [B4], True, False)
End Sub