VBA Random Sequence Algorithm

[peddy00]

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]

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:

Excel 2000
	A	B	C	D	E
1	Number of integers to return:	10		Return:	9
2	Mininum value:	1			1
3	Maximum value:	12			2
4	Desired SUM	50			8
5					6
6					5
7					7
8					5
9					5
10					2
Sheet4

In a Standard Module:

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]

Well GTO's looks great, but since i attempted it as well i am posting my results.

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]

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

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]

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]

Hi Pete,

Here's a very simple trial and error procedure (aka Monte Carlo) which may be of some interest to you

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