vba needed for random numbers within a range with no repeats

[greegan]

Good morning,

I need a vba script to randomly choose 5 numbers from a range of 1-15 in any order without repeating and itself not repeating the same combo.
ie 1,2,3,4,5 and 5,4,3,2,1 can be two different combos but those numbers in that order cannot be repeated.
If I'm right the example of 1-15 and the above order (cringe) is it 375 different combinations?
Can someone assist?

-- g

 

[shg]

Here's a UDF that does that:

Public Function RandLong(Optional iMin As Long = 1, _
                         Optional iMax As Long = -2147483647, _
                         Optional bVolatile As Boolean = False) As Variant
    ' UDF only!
    ' Returns numbers between iMin and iMax to the calling range
    ' UDF wrapper for aiRandLong
    
    ' shg 2008
    Dim nRow        As Long     ' rows in calling range
    Dim nCol        As Long     ' columns in calling range
    Dim iRow        As Long     ' row index
    Dim iCol        As Long     ' col index
    Dim aiTmp()     As Long     ' 1D temp array
    Dim aiOut()     As Long     ' output array
    If bVolatile Then Application.Volatile True
 
    With Application.Caller
        nRow = .Rows.Count
        nCol = .Columns.Count
    End With
 
    ReDim aiOut(1 To nRow, 1 To nCol)
    If iMin = 1 And iMax = -2147483647 Then iMax = nRow * nCol
    aiTmp = aiRandLong(iMin, iMax, nRow * nCol)
 
    For iRow = 1 To nRow
        For iCol = 1 To nCol
            aiOut(iRow, iCol) = aiTmp((iCol - 1) * nRow + iRow)
        Next iCol
    Next iRow
 
    RandLong = aiOut
End Function
 
Public Function aiRandLong(iMin As Long, _
                           iMax As Long, _
                           Optional ByVal n As Long = -1, _
                           Optional bVolatile As Boolean = False) As Long()
    ' UDF or VBA
    ' Fisher-Yates shuffle
    ' Returns a 1-based array of n unique Longs between iMin and iMax inclusive
    Dim aiSrc()     As Long     ' array of numbers iMin to iMax
    Dim iSrc        As Long     ' index to aiSrc
    Dim iTop        As Long     ' decreasing upper bound for next selection
    Dim aiOut()     As Long     ' output array
    Dim iOut        As Long     ' index to aiOut
 
    If bVolatile Then Application.Volatile True
 
    If n < 0 Then n = iMax - iMin + 1
    If iMin > iMax Or n > (iMax - iMin + 1) Or n < 1 Then Exit Function
 
    ReDim aiSrc(iMin To iMax)
    ReDim aiOut(1 To n)
 
    ' init iSrc
    For iSrc = iMin To iMax
        aiSrc(iSrc) = iSrc
    Next iSrc
 
    iTop = iMax

    For iOut = 1 To n
        ' Pick a number in aiSrc between 1 and iTop, copy to output,
        ' replace with the number at iTop, decrement iTop
        iSrc = Int((iTop - iMin + 1) * Rnd) + iMin
        aiOut(iOut) = aiSrc(iSrc)
        aiSrc(iSrc) = aiSrc(iTop)
        iTop = iTop - 1
    Next iOut
 
    aiRandLong = aiOut
End Function

E.g., select A1:A5 and confirm with Ctrl+Shift+Enter:

=RandLong(1,15)

is it 375 different combinations?

=PERMUT(15,5) = 360,360

 

[greegan]

Thank you, that appears to work really nicely but I might need to go into more detail?

I got the following code back in 2003...

Option Explicit
Function RandLotto(Bottom As Integer, Top As Integer, _
                    Amount As Integer) As String
    Dim iArr As Variant
    Dim i As Integer
    Dim r As Integer
    Dim temp As Integer
    
    Application.Volatile
    
    ReDim iArr(Bottom To Top)
    For i = Bottom To Top
        iArr(i) = i
    Next i
    
    For i = Top To Bottom + 1 Step -1
        r = Int(Rnd() * (i - Bottom + 1)) + Bottom
        temp = iArr(r)
        iArr(r) = iArr(i)
        iArr(i) = temp
    Next i
    
    For i = Bottom To Bottom + Amount - 1
        RandLotto = RandLotto & "," & iArr(i)
    Next i
    
    RandLotto = Trim(RandLotto)
    
End Function

which does a great job, but I would like to go further than what it offers.

It lines up the five random numbers side by side separated by a comma (,) which is what I need.
In addition to this, I need A2 to know what A1 randomly selected and not match that number group. I need A3 to do the same with the above two and A4 the same and so on and so on.
Can this be done?

-- g

 

[p45cal]

Thank you, that appears to work really nicely but I might need to go into more detail?

I got the following code back in 2003...

Option Explicit
Function RandLotto(Bottom As Integer, Top As Integer, _
                    Amount As Integer) As String
    Dim iArr As Variant
    Dim i As Integer
    Dim r As Integer
    Dim temp As Integer
    
    Application.Volatile
    
    ReDim iArr(Bottom To Top)
    For i = Bottom To Top
        iArr(i) = i
    Next i
    
    For i = Top To Bottom + 1 Step -1
        r = Int(Rnd() * (i - Bottom + 1)) + Bottom
        temp = iArr(r)
        iArr(r) = iArr(i)
        iArr(i) = temp
    Next i
    
    For i = Bottom To Bottom + Amount - 1
        RandLotto = RandLotto & "," & iArr(i)
    Next i
    
    RandLotto = Trim(RandLotto)
    
End Function

which does a great job, but I would like to go further than what it offers.

It lines up the five random numbers side by side separated by a comma (,) which is what I need.
In addition to this, I need A2 to know what A1 randomly selected and not match that number group. I need A3 to do the same with the above two and A4 the same and so on and so on.
Can this be done?

-- g

Whatdo you mean by number group?

 

[greegan]

If I were to use randlotto(1,15,5) and it produced the numbers 2,3,4,5,6 I would see that as a group of numbers I don't want repeated in the same order.

-- g

 

[p45cal]

I think there are 3003 ways to pull 5 balls from 15 balls numbered 1 to 15 out of a bag. For each of those groups of 5 balls, there are 120 ways to line them up.
The following Combins macro goes through all of the 3003 ways, and for each of those produces the 120 ways of lining them up by calling GetPermutation which calls itself a few times.
At first I wrote each combination/permutation to the spreadsheet directly, but it was taking an age, so I used arrays in memory instead. It takes less than two seconds to produce the 360360 permutations in an array - rather longer to write it to column A of the sheet - especially as I discovered that Excel 2010 won't place more than 65536 rows/cells on the sheet at a time without producing an unhelpful type mismatch error.
Then random numbers are placed in column B, both columns are then sorted on column B, and column B is deleted. Now you can run down the list knowing that each entry is unique and random (as far as excel randomising is random).

It produces results on the active sheet and has been hard coded for your 15 numbers in groups of 5.

It takes less than 30 seconds here.

Dim CurrentRow As Long
Dim Combis(1 To 360360) As String
'The above lines in the Declaration area at the top of the module.

Sub Combins()
'NOTE, IMPORTANT! At the top of the module there should be the following 2 lines (not commneted out, of course) to make global variables:
'Dim CurrentRow As Long
'Dim Combis(1 To 360360) As String



Application.ScreenUpdating = False
Dim combistr As String
Set wf = Application.WorksheetFunction
x = 0
CurrentRow = 1
For i = 1 To 11
    For j = i + 1 To 12
        For k = j + 1 To 13
            For m = k + 1 To 14
                For n = m + 1 To 15
                'because there are only 15 numbers, I converted to Hexadecimal so that all resulting strings would be 5 characters long.
                    combistr = wf.Dec2Hex(i) & wf.Dec2Hex(j) & wf.Dec2Hex(k) & wf.Dec2Hex(m) & wf.Dec2Hex(n)
                    'Debug.Print combistr
                    GetPermutation "", combistr
                    x = x + 1
                Next n
            Next m
        Next k
    Next j
Next i
'Debug.Print x

'The following writes the array to column A in blocks of 65536 as it doesn't like writing the array in one go:
'Later I added Hex to Decimal conversion.
Dim yyy(1 To 65536)
x = UBound(Combis)
Range("A1").Resize(x).NumberFormat = "@"
For i = 1 To x Step 65536
    Erase yyy
    ThisArrayMax = Application.Min(65536, x - i + 1)
    For j = 1 To ThisArrayMax
        'yyy(j) = Combis(i + j - 1)
        OriginalString = Combis(i + j - 1)
        NewString = ""
        For k = 1 To 5
        NewString = NewString & wf.Hex2Dec(Mid(OriginalString, k, 1)) & ","
        Next k
        yyy(j) = Left(NewString, Len(NewString) - 1)
    Next j
    ActiveSheet.Range("A" & i).Resize(ThisArrayMax).Value = wf.Transpose(yyy)
    'ActiveWindow.ScrollRow = i + j - 5
Next i

'Now sort randomly (you can comment out this block to retain an ordered list):
With Range("B1").Resize(x)
    .Formula = "=rand()"
    .Value = .Value
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1").Resize(x, 2)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    .ClearContents
End With

Application.ScreenUpdating = True
End Sub



Sub GetPermutation(x As String, y As String)
'from:http://j-walk.com/ss/excel/tips/tip46.htm
'   The source of this algorithm is unknown
Dim i As Integer, j As Integer
j = Len(y)
If j < 2 Then
    'Cells(CurrentRow, 1) = x & y
    Combis(CurrentRow) = x & y
    CurrentRow = CurrentRow + 1
Else
    For i = 1 To j
        Call GetPermutation(x + Mid(y, i, 1), Left(y, i - 1) + Right(y, j - i))
    Next
End If
End Sub

 

[greegan]

First off, WOW this is awesome!
Second, how do I use it? I keep reading the post and I can't understand where to begin (pebkac error).
Third, if I would want to change the range from 16 to 30 which lines will I need to change?
-- g

Ps
Did I say this is awesome? Thanks!

 

[p45cal]

how do I use it? I keep reading the post and I can't understand where to begin (pebkac error).

The easiest way would be to paste my entire code into a completely blank standard code module, then make sure you have a fresh new blank worksheet as the active sheet, then run the macro Combins.

Third, if I would want to change the range from 16 to 30 which lines will I need to change?

A lot! (There'd be about 50 times as many results, requiring more than 17 million cells (many more than in a single column in xl2010)).

 

[greegan]

Great! Okay so I run the macro and "wf" is a variable not defined. Can i make that a string or is there something else you recommend?
Thank you again.
I am a little confused on how the 16-30 range would generate more combinations than the 1-15. If there are only 15 numbers what would be the difference? I'm not trying to be difficult, only trying to understand how that works.
-- g

 

[greegan]

Where it says

Set wf = Application.WorksheetFunction

I get a compile error: variable not defined

And...

 wf =

is highlighted