Random Numbers totaling "X".

[ceranes]

I want to create a list of random numbers, preferably the ability to choose however many I need so that their total sum equals a value "X".

As an example, I need 5 random numbers that total 6,000. I do not want decimals.

Any ideas?

Thanks,
Chris

 

[shg]

UDF?

	A​	B​	C​	D​	E​	F​	G​
2​	2241​	2501​	433​	596​	229​		A2:E2: {=RandLen(6000)}

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

  ' UDF wrapper for adRandLen

  Dim adTmp()       As Double
  Dim adOut()       As Double
  Dim iRow          As Long
  Dim nRow          As Long
  Dim iCol          As Long
  Dim nCol          As Long

  If bVolatile Then Application.Volatile

  nRow = Application.Caller.Rows.Count
  nCol = Application.Caller.Columns.Count

  adTmp = adRandLen(dTot, nRow * nCol, dMin, iSig)
  ReDim adOut(1 To nRow, 1 To nCol)

  For iRow = 1 To nRow
    For iCol = 1 To nCol
      adOut(iRow, iCol) = adTmp((iRow - 1) * nCol + iCol)
    Next iCol
  Next iRow

  RandLen = adOut
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

 

[Joe4]

Welcome to the Board!

Here is my stab at it. There is a procedure that prompts you for your total, and the number of random numbers that you want that equal that total. I then returns them to a MsgBox, separated by semi-colons, but that can easily be changed to return wherever you want.

Sub GenerateRandomNums()

    Dim total As Long
    Dim num As Long
    Dim l As Long
    Dim mySum As Long
    Dim upper As Long
    Dim rndNum As Long
    Dim vals As String
    
'   Prompt user for entry
    total = InputBox("What is the total you want the numbers to add up to?")
'   Check entry
    If total < 0 Then
        MsgBox "Total must be greater than zero", vbOKOnly, "ENTRY ERROR!"
        Exit Sub
    End If
    
'   Prompt user for entry
    num = InputBox("How many random numbers do you want?")
'   Check entry
    If num < 2 Then
        MsgBox "Number of random numbers must be at least 2", vbOKOnly, "ENTRY ERROR!"
        Exit Sub
    End If

'   Find all random numbers expect last one
    For l = 1 To (num - 1)
        upper = total - mySum
        rndNum = RandNum(1, upper)
        vals = vals & rndNum & ";"
        mySum = mySum + rndNum
    Next l

'   Find last random number
    rndNum = total - mySum
    vals = vals & rndNum
    
'   Return list of random numbers
    MsgBox vals

End Sub


Function RandNum(lower As Long, upper As Long) As Integer
'   Find a random number between the two numbers
    RandNum = Int((upper - lower + 1) * Rnd + lower)
End Function

 

[ceranes]

Thanks guys...I appreciate the help. I will give these a try.

 

[Eric W]

Here's a formula solution:

	A	B	C	D
1	Sum	Count		List
2	6000	6		3115
3				510
4				1361
5				289
6				443
7				282
8

<colgroup><col style="width: 25pxpx"><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet11​

Worksheet Formulas Cell Formula D2 =IF(ROWS($D$2:$D2)>$B$2,"",IF(ROWS($D$2:$D2)=$B$2,$A$2-SUM($D$1:$D1),RANDBETWEEN(1,$A$2-SUM($D$1:$D1)-($B$2-ROWS($D$2:$D2))))) <thead> </thead><tbody> </tbody>

<tbody>
</tbody>

Just press F9 for a new set.

 

[shg]

Cross-posted at https://www.excelforum.com/excel-general/1216243-random-numbers-whose-sums-equals-x.html

 

[Joe4]

Cross-posted at https://www.excelforum.com/excel-gen...-equals-x.html

ceranes,
While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules). This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.