Creating random numbers that add up to a specific number

[PapaCheese]

Hi,

I want to create random numbers in cells A1 to A9 that would add up to 146501.

Any ideas?

[shg]

Function RandLen(dTot As Double, _
                 Optional dMin As Double = 0#, _
                 Optional ByVal iSig As Long = 0, _
                 Optional bVolatile As Boolean = False) As Variant
    ' shg 2011

    ' UDF wrapper for adRandLen

    If bVolatile Then Application.Volatile

    With Application.Caller
        If .Rows.Count > 1 And .Columns.Count > 1 Then
            RandLen = CVErr(xlErrRef)

        ElseIf .Columns.Count > 1 Then
            RandLen = adRandLen(dTot, .Columns.Count, dMin, iSig)

        Else
            RandLen = WorksheetFunction.Transpose(adRandLen(dTot, .Rows.Count, dMin, iSig))
        End If
    End With
End Function

Function adRandLen(ByVal dTot As Double, _
                   nOut As Long, _
                   Optional ByVal dMin As Double = 0#, _
                   Optional ByVal iSig As Long = 307) As Double()
    ' shg 2011

    ' Applies string-cutting to return an array of nOut
    ' numbers totalling dTot, with each in the range

    '    dMin <= number <= Round(dTot, iSig) - nOut * round(dMin, iSig)

    ' Each number is rounded to iSig decimals

    Dim iOut        As Long     ' index to iOut
    Dim jOut        As Long     ' sort insertion point
    Dim dRnd        As Double   ' random number
    Dim dSig        As Double   ' decimal significance (e.g., 1, 0.01, ...)
    Dim adOut()     As Double   ' output array

    dTot = WorksheetFunction.Round(dTot, iSig)
    dMin = WorksheetFunction.Round(dMin, iSig)
    If nOut < 1 Or dTot < nOut * dMin Then Exit Function

    ReDim adOut(1 To nOut)
    dSig = 10# ^ -iSig

    With New Collection
        .Add Item:=0#
        .Add Item:=dTot - nOut * dMin

        ' create the cuts
        For iOut = 1 To nOut - 1
            dRnd = Int(Rnd * ((dTot - nOut * dMin) / dSig)) * dSig

            ' insertion-sort the cut
            For jOut = .Count To 1 Step -1
                If .Item(jOut) <= dRnd Then
                    .Add Item:=dRnd, After:=jOut
                    Exit For
                End If
            Next jOut
        Next iOut

        ' measure the lengths
        For iOut = 1 To nOut
            adOut(iOut) = .Item(iOut + 1) - .Item(iOut) + dMin
        Next iOut
    End With

    adRandLen = adOut
End Function

Copy the code to a code module, select A1:A9, and confirm with Ctrl+Shift+Enter:

=RandLen(146501)

       --A--- ------------B------------
   1     2053 A1:A9: {=RandLen(146501)}
   2    40368                          
   3     1814                          
   4    33912                          
   5     6753                          
   6    18463                          
   7     8083                          
   8     2054                          
   9    33001                          
  10   146501 A10: =SUM(A1:A9)