vba needed for random numbers within a range with no repeats

greegan

Well-known Member
Joined
Nov 18, 2009
Messages
644
Office Version
  1. 365
Platform
  1. Windows
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
 
I didn't have option explicit at the top of the module, temporarily remove this line to see it working. Afterward, you can Dim all the variables.
 
Upvote 0

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
hmm ...

using only elementary operations of counting, comparison and logical true or false - with plenty of looping.

seems to take maybe 5 secs (Excel 2007)
Code:
Option Explicit
Const smallno = 5
Const largeno = 15
Sub sometestcode()
Dim z&(), y(), k&, g() As String
Dim a&, b&, c&, d&, boo() As Boolean, tmp&
ReDim y(1 To largeno ^ smallno, 1 To smallno), g(1 To largeno ^ smallno, 1 To 1)
ReDim z(1 To largeno)
For a = 1 To largeno: z(a) = a: Next a
For a = 1 To smallno
    For b = 1 To largeno ^ smallno Step largeno ^ a
        For c = b To b + largeno ^ (a - 1) - 1
            For d = 1 To largeno
                y(c + largeno ^ (a - 1) * (d - 1), smallno - a + 1) = z(d)
Next d, c, b, a
For a = 1 To largeno ^ smallno
ReDim boo(largeno)
For b = 1 To smallno
    If boo(y(a, b)) = True Then GoTo zub
    boo(y(a, b)) = True
Next b
k = k + 1
g(k, 1) = y(a, 1)
For b = 2 To smallno: g(k, 1) = g(k, 1) & "," & y(a, b): Next b
zub:
Next a
ReDim z(1 To k)
For a = 1 To k: z(a) = a: Next a
For a = 1 To k
    b = Int(Rnd * (k - a + 1)) + a
    tmp = z(a): z(a) = z(b): z(b) = tmp
Next a
For a = 1 To k: y(a, 1) = g(z(a), 1): Next a
Range("B1").Resize(k) = y
End Sub
 
Upvote 0
Where it says
Code:
Set wf = Application.WorksheetFunction
I get a compile error: variable not defined

And...
Code:
 wf =
is highlighted

I've changed the code a bit below - all variables are defined and I've made it so that you can paste the whole shooting match into a virgin standard code module. It runs faster too.
Code:
Option Explicit
Dim CurrentRow As Long
Dim Combis(1 To 360360, 0) As String

Sub Combins()
Dim wf, x As Long, i As Long, j As Long, k As Long, m As Long, n As Long
Dim OriginalString As String, NewString 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

'Hex to Decimal conversion.
x = UBound(Combis)
For i = 1 To x
    OriginalString = Combis(i, 0)
    NewString = ""
    For k = 1 To 5
        NewString = NewString & wf.Hex2Dec(Mid(OriginalString, k, 1)) & ","
    Next k
    Combis(i, 0) = Left(NewString, Len(NewString) - 1)
Next i
'The following writes the array to column A:
With Range("A1").Resize(x)
    .Value = Combis
End With
'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)
'http://www.mrexcel.com/forum/showthread.php?p=2827068
'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, 0) = 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
 
Last edited:
Upvote 0
hmm ...

using only elementary operations of counting, comparison and logical true or false - with plenty of looping.

seems to take maybe 5 secs (Excel 2007)
Code:
For a = 1 To k: y(a, 1) = g(z(a), 1): Next a
Range("B1").Resize(k) = y
End Sub

I learnt one or two things today:
When I came across mirabeau's snippet above I thought 'how on earth did he manage to write the whole range in one go?'.
Turns out that my "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" is just so much drivel, and that it's the transpose which doesn't like numbers greater than 65536. So I made alterations to my code, whic now only takes twice as long as mirabeau's solution.

The other thing I learnt was the likes of:
Next d, c, b, a

Thanks mirabeau.
 
Upvote 0

Forum statistics

Threads
1,224,597
Messages
6,179,813
Members
452,945
Latest member
Bib195

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top