# Thread: Randomly Distributing a Sum Over Cells Thanks:  3 Post #5316707 (1)Post #5316757 (1)Post #5316566 (1) Likes: 0

1. ## Randomly Distributing a Sum Over Cells

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.

2. ## Re: Randomly Distributing a Sum Over Cells

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

3. ## Re: Randomly Distributing a Sum Over Cells

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

4. ## Re: Randomly Distributing a Sum Over Cells

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.

5. ## Re: Randomly Distributing a Sum Over Cells

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?

6. ## Re: Randomly Distributing a Sum Over Cells

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

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.

Code:
```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```