Randomly Distributing a Sum Over Cells

[HGLIII]

Would it be possible to randomly distribute a sum (say 100,000) over 10 distinct cells?

"0" is an acceptable result for any given cell, and in fact 9 out of 10 cells could feature 0 with the final cell containing the full 100,000.

I am just trying to randomly distribute the sum (on a RANDBETWEEN type basis), so that I can calculate many different outcomes.

Any help would be greatly appreciated!

Thanks.

 

[mikerickson]

Put =RANDBETWEEN(0, 100000) in A1
Put =RANDBETWEEN(0, 100000 - SUM(A$1:A1$)) in A2
Drag down

 

[HGLIII]

Thanks very much Mike - would it be possible to place a floor / minimum on each result so that you generate numbers in 10,000 increments?

For example:

1. 10,000
2. 0
3. 0
4. 50,000
5. 0
6. 0
7. 30,000
8. 0
9. 0
10. 10,000

Total = 100,000

 

[shg]

Like this?

	A​	B​	C​	D​	E​	F​	G​	H​	I​	J​	K​
1​	​	​	​	​	​	​	​	​	​	​	Total​
2​	0​	0​	0​	10,000​	0​	10,000​	10,000​	20,000​	40,000​	10,000​	100,000​
3​	0​	10,000​	10,000​	10,000​	10,000​	10,000​	20,000​	0​	20,000​	10,000​	100,000​
4​	10,000​	20,000​	10,000​	0​	10,000​	0​	20,000​	10,000​	20,000​	0​	100,000​
5​	0​	10,000​	20,000​	10,000​	10,000​	10,000​	20,000​	20,000​	0​	0​	100,000​
6​	0​	0​	20,000​	10,000​	0​	0​	40,000​	10,000​	0​	20,000​	100,000​
7​	0​	20,000​	20,000​	10,000​	0​	0​	20,000​	10,000​	20,000​	0​	100,000​
8​	20,000​	20,000​	0​	10,000​	0​	0​	10,000​	10,000​	20,000​	10,000​	100,000​
9​	0​	10,000​	0​	10,000​	10,000​	20,000​	10,000​	40,000​	0​	0​	100,000​
10​	0​	20,000​	0​	0​	10,000​	20,000​	0​	10,000​	30,000​	10,000​	100,000​
11​	10,000​	0​	0​	20,000​	0​	10,000​	20,000​	30,000​	10,000​	0​	100,000​

It uses a user-defined function.

 

[HGLIII]

Thanks shg, I think that's exactly what I need.

Not too familiar with user-defined functions - any idea how best to proceed with recreating this?

 

[shg]

1. Copy the code below from the post
2. In Excel, press Alt+F11 to open the Visual Basic Editor (VBE)
3. From the menu bar in the VBE window, do Insert > Module
4. Paste the code in the window that opens
5. Press Alt+Q to close the VBE and return to Excel

Select A2:J2, paste =RandLen(10) * 10000 in the formula bar, press and hold the Ctrl and Shift keys, then press Enter. Then drag down.

Function RandLen(iTot As Long, _
                 Optional iMin As Long = 0&, _
                 Optional iMax As Long = 2147483647, _
                 Optional bDist As Boolean = False, _
                 Optional bVolatile As Boolean = False) As Long()

  ' shg 2011, 2018 (added iMax)
  ' UDF wrapper for aiRandLenMinMax

  Dim aiTmp()       As Long
  Dim aiOut()       As Long
  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

  aiTmp = aiRandLenMinMax(iTot, nRow * nCol, iMin, iMax, bDist)
  ReDim aiOut(1 To nRow, 1 To nCol)

  For iRow = 1 To nRow
    For iCol = 1 To nCol
      aiOut(iRow, iCol) = aiTmp((iRow - 1) * nCol + iCol)
    Next iCol
  Next iRow

  RandLen = aiOut
End Function

Function aiRandLenMinMax(ByVal iTot As Long, _
                         k As Long, _
                         Optional ByVal iMin As Long = 0&, _
                         Optional ByVal iMax As Long = 2147483647, _
                         Optional bDist As Boolean = False) As Long()

  ' shg 2018
  ' VBA only

  Dim ai()          As Long   ' initially cuts, and then lengths
  Dim i             As Long
  Dim iCut          As Long
  Dim iTmp          As Long

  If k < 1 Then Exit Function
  If iMin < 0 Then iMin = 0
  If iTot < k * iMin Then Exit Function
  If iMax < iTot \ k Then Exit Function

  If iMax > iTot Then iMax = iTot
  iTot = iTot - k * iMin                         ' accommodate min
  If bDist Then iTot = iTot - k * (k - 1&) \ 2&  ' accommodate distinct

  ReDim ai(1 To k + 1)

  ' make cuts at intervals that ensure values w/in max
  For i = 0& To iTot Step iMax - iMin - IIf(bDist, k - 1&, 0&)
    iCut = iCut + 1&
    ai(iCut) = i
  Next i

  ' there must be a cut at the top of the string
  If ai(iCut) <> iTot Then
    iCut = iCut + 1&
    ai(iCut) = iTot
  End If

  ' make the rest of the cuts
  For iCut = iCut + 1& To k + 1&
    ai(iCut) = Int(Rnd() * (iTot + 1&))
  Next iCut

  ' sort the cuts and measure the lengths between
  InsertionSort ai
  For i = 1 To k
    iTmp = ai(i)
    ai(i) = ai(i + 1&) - iTmp + iMin
  Next i

  ' get rid the the extra entry
  ReDim Preserve ai(1& To k)

  If bDist Then
    InsertionSort ai

    For i = 1 To k
      ai(i) = ai(i) + i - 1&
    Next i

    FYShuffle1D ai
  End If

  aiRandLenMinMax = ai
End Function

Function InsertionSort(ByRef av As Variant) As Boolean
  ' Sorts 1D or 2D array av in situ; if 2D, one dimension must be 1

  Dim iLB           As Long
  Dim iUB           As Long
  Dim LB            As Long
  Dim i             As Long
  Dim j             As Long
  Dim v             As Variant

  Select Case NumDim(av)
    Case 0, Is > 2
      ' not an array, or > 2 dimensions

    Case 1
      iLB = LBound(av)
      iUB = UBound(av)

      For i = iLB + 1 To iUB
        v = av(i)

        For j = i - 1 To iLB Step -1
          If av(j) <= v Then Exit For
          av(j + 1) = av(j)
        Next j

        av(j + 1) = v
      Next i
      InsertionSort = True

    Case 2
      If UBound(av, 1) - LBound(av, 1) > 0 Then
        If UBound(av, 2) - LBound(av, 2) > 0 Then Exit Function

        iLB = LBound(av, 1)
        iUB = UBound(av, 1)
        LB = LBound(av, 2)

        For i = iLB + 1 To iUB
          v = av(i, LB)

          For j = i - 1 To iLB Step -1
            If av(j, LB) <= v Then Exit For
            av(j + 1, LB) = av(j, LB)
          Next j

          av(j + 1, LB) = v
        Next i
        InsertionSort = True

      Else
        iLB = LBound(av, 2)
        iUB = UBound(av, 2)
        LB = LBound(av, 1)

        For i = iLB + 1 To iUB
          v = av(LB, i)

          For j = i - 1 To iLB Step -1
            If av(LB, j) <= v Then Exit For
            av(LB, j + 1) = av(LB, j)
          Next j

          av(LB, j + 1) = v
        Next i
        InsertionSort = True
      End If
  End Select
End Function

Sub FYShuffle1D(av As Variant)
  ' shg 2015

  ' In-situ Fisher-Yates shuffle of 1D array av
  ' VBA only

  Dim iLB           As Long
  Dim iTop          As Long
  Dim vTmp          As Variant
  Dim iRnd          As Long

  iLB = LBound(av)
  iTop = UBound(av) - iLB + 1

  Do While iTop
    iRnd = Int(Rnd * iTop)
    iTop = iTop - 1
    vTmp = av(iTop + iLB)
    av(iTop + iLB) = av(iRnd + iLB)
    av(iRnd + iLB) = vTmp
  Loop
End Sub