Randomly Distributing a Sum Over Cells
Results 1 to 6 of 6

Thread: Randomly Distributing a Sum Over Cells

  1. #1
    New Member
    Join Date
    Jun 2019
    Posts
    14
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default 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. #2
    MrExcel MVP mikerickson's Avatar
    Join Date
    Jan 2007
    Location
    Davis CA
    Posts
    22,519
    Post Thanks / Like
    Mentioned
    20 Post(s)
    Tagged
    15 Thread(s)

    Default 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. #3
    New Member
    Join Date
    Jun 2019
    Posts
    14
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default 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. #4
    MrExcel MVP shg's Avatar
    Join Date
    May 2008
    Location
    The Great State of Texas
    Posts
    21,602
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    14 Thread(s)

    Default 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. #5
    New Member
    Join Date
    Jun 2019
    Posts
    14
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default 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. #6
    MrExcel MVP shg's Avatar
    Join Date
    May 2008
    Location
    The Great State of Texas
    Posts
    21,602
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    14 Thread(s)

    Default 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
    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.

    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
    Last edited by shg; Jul 29th, 2019 at 10:30 AM. Reason: missed some stuff

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •