sbRandIntFixSum (VBA)

Thu, 14 May 2026 11:46:00 +0100

Abstract

Sie wollen lCount ganze Zufallszahlen zwischen lMin und lMax mit der Summe lSum erzeugen?

Diese benutzerdefinierte Funktion ist eng mit sbLongRandSumN verwandt.

Appendix Programmcode sbRandIntFixSum

Dieses Programm benötigt (ruft auf) sbRandTriang.

Bitte den Haftungsausschluss im Impressum beachten.

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): https://www.sulprobil.de/sbrandintfixsum_en/
'Source (DE): https://www.berndplumhoff.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

Download

Bitte den Haftungsausschluss im Impressum beachten.

SbRandIntFixSum on Bernd Plumhoff

sbRandIntFixSum (VBA)

Abstract

Appendix Programmcode sbRandIntFixSum

Download