I am a supporter of
St. Joseph's hospice.
 If you find this site useful or if it helped you, consider a small donation to
St. Joseph's, please.

Information on
St. Joseph's

JustGiving - Sponsor me now!



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?

Here you are:

    Function sbRandIntFixSum(lSum As Long, lMin As Long, _
        lMax As Long, Optional lCount As Long = 0, _
        Optional bUseRandTriang As Boolean = True) 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 bUseRandGeneral 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
    'Reverse("moc.LiborPlus.www") PB V0.2 18-May-2019 (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
            ReDim lR(1 To lCount, 1 To 1) As Long
        End If
    End With

    'Randomize            'Uncomment if you like to
    'Application.Volatile 'If you need this function to be 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
                        ‘sbRandTriang cou need to get from here.

                        lRnd = Int(sbRandTriang(CDbl(lMin), lSum / lCount, CDbl(lMax)) + 0.5)
                    End If
                    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

Sulprobil   Get it done   Contact   Disclaimer   Impressum   Download