VBA Random Sequence Algorithm

peddy00

New Member
Joined
Aug 19, 2012
Messages
27
Hi,

Suppose you'd like a sequence of length n composed of random integers between 0 and x. Furthermore, the sum of the sequence must be y. Repetition within the sequence is permitted. The output should come out starting at A1 and end at An.

Is there an efficient algorithm that can do this in VBA, within Excel?

To add another wrinkle to this, if possible, have it output values, as opposed to formulas. Specifically, when you use the RAND() formula in Excel, it changes values. Ideally, the output in column A would be static.

Thanks,
Pete
 

GTO

MrExcel MVP
Joined
Dec 9, 2008
Messages
6,154
Here is a small try. I would expect it to get awfully slow if the numbers of random values to produce the sum is very great at all.

Change the CodeName of the worksheet to 'shtRandToSum'. With a layout of:
<b>Excel 2000</b><table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color: #E0E0F0" /><col /><col /><col /><col /><col /></colgroup><thead><tr style=" background-color: #E0E0F0;text-align: center;color: #161120"><th></th><th>A</th><th>B</th><th>C</th><th>D</th><th>E</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">1</td><td style="border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;background-color: #CCCCFF;;">Number of integers to return:</td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">10</td><td style="text-align: right;border-right: 1px solid black;border-left: 1px solid black;;"></td><td style="border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;background-color: #99CCFF;;">Return:</td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">9</td></tr><tr ><td style="color: #161120;text-align: center;">2</td><td style="border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;background-color: #CCCCFF;;">Mininum value:</td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">1</td><td style="text-align: right;border-left: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">1</td></tr><tr ><td style="color: #161120;text-align: center;">3</td><td style="border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;background-color: #CCCCFF;;">Maximum value:</td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">12</td><td style="text-align: right;border-left: 1px solid black;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">2</td></tr><tr ><td style="color: #161120;text-align: center;">4</td><td style="border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;background-color: #CCCCFF;;">Desired SUM</td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">50</td><td style="text-align: right;border-left: 1px solid black;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">8</td></tr><tr ><td style="color: #161120;text-align: center;">5</td><td style="text-align: right;border-top: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">6</td></tr><tr ><td style="color: #161120;text-align: center;">6</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">5</td></tr><tr ><td style="color: #161120;text-align: center;">7</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">7</td></tr><tr ><td style="color: #161120;text-align: center;">8</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">5</td></tr><tr ><td style="color: #161120;text-align: center;">9</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">5</td></tr><tr ><td style="color: #161120;text-align: center;">10</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;border-right: 1px solid black;;"></td><td style="text-align: right;border-top: 1px solid black;border-right: 1px solid black;border-bottom: 1px solid black;border-left: 1px solid black;;">2</td></tr></tbody></table><p style="width:3.6em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid #A6AAB6;border-top:none;text-align: center;background-color: #E0E0F0;color: #161120">Sheet4</p><br /><br />

In a Standard Module:
Rich (BB code):
Option Explicit
    
Sub LimitedRandomMaybe()
Dim aryRandVals         As Variant
Dim lMin                As Long
Dim lMax                As Long
Dim lSum                As Long
Dim n                   As Long
Dim bolEntryError       As Boolean
Dim bolRandsEqualSum    As Boolean
Dim bolTimeExceeded     As Boolean
'// Rudimentary and will not work if close enough to Midnight when started..., but  //
'// I would want some type of fail safe to prevent a never ending loop.             //
Dim TimeHack As Double: TimeHack = CDbl(Time + TimeValue("00:01:00")) * 24 * 60 * 60
    
    With shtRandToSum
        '// Some type of checking to ensure we have valid integers needed.          //
        If IsNumeric(.Cells(1, 2).Value) _
        And IsNumeric(.Cells(2, 2).Value) _
        And IsNumeric(.Cells(3, 2).Value) _
        And IsNumeric(.Cells(4, 2).Value) Then
            
            If Int(.Cells(1, 2).Value) = .Cells(1, 2).Value _
            And Int(.Cells(2, 2).Value) = .Cells(2, 2).Value _
            And Int(.Cells(3, 2).Value) = .Cells(3, 2).Value _
            And Int(.Cells(4, 2).Value) = .Cells(4, 2).Value Then
                
                If .Cells(1, 2).Value > 0 _
                And .Cells(2, 2).Value > 0 _
                And .Cells(3, 2).Value > 0 _
                And .Cells(4, 2).Value > 0 Then
                Else: bolEntryError = True
                End If
            Else: bolEntryError = True
            End If
        Else: bolEntryError = True
        End If
        '// Bailout if missing/bad values inputted                                  //
        If bolEntryError Then
            MsgBox "You're hurting my poor brain; I quit!", vbInformation, vbNullString
            Exit Sub
        End If
        
        '// Size array to same number of elements as user wants                     //
        ReDim aryRandVals(1 To .Cells(1, 2).Value, 1 To 1) As Long
        
        Randomize
        
        lMin = .Cells(2, 2).Value
        lMax = .Cells(3, 2).Value
        lSum = .Cells(4, 2).Value
        
        '// Loop until we get a good answer or run out of time                      //
        Do While Not bolRandsEqualSum And Not bolTimeExceeded
            For n = 1 To UBound(aryRandVals)
                aryRandVals(n, 1) = Int((lMax - lMin + 1) * Rnd + lMin)
            Next
            If Application.Sum(aryRandVals) = lSum Then bolRandsEqualSum = True
            If Timer > TimeHack Then bolTimeExceeded = True
        Loop
        
        If bolTimeExceeded Then
            MsgBox "Try less numbers or something, this took too long...", _
                    vbInformation, _
                    vbNullString
        Else
            .Columns(5).Clear
            .Cells(1, 5).Resize(UBound(aryRandVals, 1)).Value = aryRandVals
        End If
    End With
End Sub
Hope that helps,
Mark
 

bstory84

Active Member
Joined
Oct 31, 2011
Messages
403
Well GTO's looks great, but since i attempted it as well i am posting my results.
Code:
Sub RndAlg()
Dim n As Long
Dim y As Long
Dim x As Long
Dim Arr_results() As Variant
Dim IL As Long
Dim difARR As Long
'set your parameters below
n = 5   'LENGTH - NUMBER OF RND NUMBERS
y = 54  'SUM DESIRED
x = 17  'HIGH RND NUM
IL = 0
ReDim Arr_results(1 To n)
For i = 1 To n
AGAIN:
If IL > 10000 Then GoTo INFINITE
    If i < n Then
        Arr_results(i) = WorksheetFunction.RandBetween(0, x)
            If WorksheetFunction.Sum(Arr_results()) > y Then
                IL = IL + 1
                GoTo AGAIN
             Else
            End If
    Else
        difARR = y - WorksheetFunction.Sum(Arr_results())
        Arr_results(i) = difARR
    End If
    
Next i
For R = 1 To n
    Sheet1.Cells(R, 1) = Arr_results(R)
Next R
   
Exit Sub
INFINITE:
MsgBox "INFIINTE LOOP DETECTED"
End Sub
 

mirabeau

Banned user
Joined
Nov 4, 2010
Messages
2,075
Hi,

Suppose you'd like a sequence of length n composed of random integers between 0 and x. Furthermore, the sum of the sequence must be y. Repetition within the sequence is permitted. The output should come out starting at A1 and end at An.

Is there an efficient algorithm that can do this in VBA, within Excel?

To add another wrinkle to this, if possible, have it output values, as opposed to formulas. Specifically, when you use the RAND() formula in Excel, it changes values. Ideally, the output in column A would be static.

Thanks,
Pete
Hi Pete,

Here's a very simple trial and error procedure (aka Monte Carlo) which may be of some interest to you
Code:
Sub sum_random()
Dim n As Long, x As Long, y As Long

n = 10
x = 30
y = 100

With Range("A1").Resize(n)
    Do
        .Cells = "=int(rand()*" & x + 1 & ")"
    Loop Until y = Evaluate("sum(" & .Address & ")")
    .Value = .Value
End With
End Sub
"God doesn't play dice with the universe" (Albert Einstein - taken out of context)
(Many years earlier Pierre-Simon Laplace, in his famous lampoon of pure determinism, had suggested the contrary.)
 

tusharm

MrExcel MVP
Joined
May 28, 2002
Messages
11,007
This looks like a homework assignment ;) and even if not the best I can do right now is give you an outline.

Create the power set of the numbers 1...X (see Power Set)

The power set will contain 2^N sets. Discard all sets that have >N elements.

Discard any set in which the elements do not sum to Y.

'Save' the remaining sets.

As needed, pick one of these saved sets at random. If the number of elements <N pad with zeros.

Hi,

Suppose you'd like a sequence of length n composed of random integers between 0 and x. Furthermore, the sum of the sequence must be y. Repetition within the sequence is permitted. The output should come out starting at A1 and end at An.

Is there an efficient algorithm that can do this in VBA, within Excel?

To add another wrinkle to this, if possible, have it output values, as opposed to formulas. Specifically, when you use the RAND() formula in Excel, it changes values. Ideally, the output in column A would be static.

Thanks,
Pete
 

peddy00

New Member
Joined
Aug 19, 2012
Messages
27
Hi Pete,

Here's a very simple trial and error procedure (aka Monte Carlo) which may be of some interest to you
Code:
Sub sum_random()
Dim n As Long, x As Long, y As Long

n = 10
x = 30
y = 100

With Range("A1").Resize(n)
    Do
        .Cells = "=int(rand()*" & x + 1 & ")"
    Loop Until y = Evaluate("sum(" & .Address & ")")
    .Value = .Value
End With
End Sub
"God doesn't play dice with the universe" (Albert Einstein - taken out of context)
(Many years earlier Pierre-Simon Laplace, in his famous lampoon of pure determinism, had suggested the contrary.)
Hi mirabeau and all,

Thanks for the suggestion. That's what I'm going with. Nice and simple. I realize that it is technically unbounded in how long it will take, but my n and x values will be relatively small, with x always being less than n. I probably should have mentioned that. As y gets close to (x+1)^n, though, the algorithm could take a very long time. But, in those cases, I'll fill in x in each cell, and then, as randomly as I can, decrease the sum from nx to y.

Thanks for your suggestions.

Pete
 

Forum statistics

Threads
1,085,031
Messages
5,381,303
Members
401,733
Latest member
Kabasa007

Some videos you may like

This Week's Hot Topics

Top