Unique Random Numbers

[Paul Black]

Hi,

I would like to generate unique random numbers from say 34 numbers,
and starting in "B2" list them in 5 number combinations going down
until ALL the 34 numbers have been used. I know in this example the
first 6 combinations will have 5 numbers and the 7th combination will
have only 4.
There may be occassions where there might be more or less numbers than
34 numbers and maybe 4,5,6 or 7 number combinations so code where I
could adapt it accordingly will be much appreciated.

Thanks in advance,
Paul

 

[joeu2004]

I would like to generate unique random numbers from say 34
numbers, and starting in "B2" list them in 5 number
combinations going down until ALL the 34 numbers have been
used. I know in this example the first 6 combinations will
have 5 numbers and the 7th combination will have only 4.
There may be occassions where there might be more or less
numbers than 34 numbers and maybe 4,5,6 or 7 number
combinations

See the UDF below. Use as you would RANDBETWEEN, e.g.
=uniqRandBetween(1,34).

Each uniqRandBetween range has its own pool of unique random numbers. So
two calls to uniqRandBetween(1,34) will generate a unique pair of numbers;
but a call to uniqRandBetween(1,34) and uniqRandBetween(1,20) might result
in the same random number.

As currently configured, uniqRandBetween supports up to 10 different ranges,
each with a maximum range of 100 values (hi - lo + 1). Change the Const
variable maxNTabl and maxN as needed.

To enter the UDF, in Excel, press alt+F8 to open the VBA window. In VBA,
click on Insert, then Module to open a VBE pane. Copy the text of the UDF
below and paste it into the VBE pane. You can now close the VBA window.

The UDF....

Option Explicit

Function uniqRandBetween(lo As Long, hi As Long)

'***** customize *****
' maxNtabl = number of lo-to-hi ranges
' maxN = max size of range, hi-lo+1
'******
Const maxNtabl As Long = 10
Const maxN As Long = 100

Static tabl(1 To maxNtabl, 1 To 3 + maxN) As Long
Static ntabl As Long
Dim t As Long, n As Long, x As Long

' find table for lo-to-hi range

If lo > hi Then GoTo retnError
For t = 1 To ntabl
If tabl(t, 1) = lo And tabl(t, 2) = hi Then GoTo continue
Next
If ntabl >= maxNtabl Then GoTo retnError
If hi - lo + 1 > maxN Then GoTo retnError
ntabl = ntabl + 1
t = ntabl
tabl(t, 1) = lo
tabl(t, 2) = hi
tabl(t, 3) = 0

continue:

' generate list of random numbers, if needed

n = tabl(t, 3)
If n = 0 Then
For n = 1 To hi - lo + 1
tabl(t, 3 + n) = lo + n - 1
Next
n = n - 1
End If

' generate unique random number.
'
' note: you might want to change Rnd to
' Evaluate("RAND()") to use Excel RAND.
' slower, but more maybe robust.

x = 1 + Int(n * Rnd)
uniqRandBetween = tabl(t, 3 + x)
If x < n Then tabl(t, 3 + x) = tabl(t, 3 + n)
tabl(t, 3) = n - 1
Exit Function

retnError:

uniqRandBetween = CVErr(xlErrValue)
End Function

 

[Martin Brown]

Hi,

I would like to generate unique random numbers from say 34 numbers,
and starting in "B2" list them in 5 number combinations going down
until ALL the 34 numbers have been used. I know in this example the
first 6 combinations will have 5 numbers and the 7th combination will
have only 4.
There may be occassions where there might be more or less numbers than
34 numbers and maybe 4,5,6 or 7 number combinations so code where I
could adapt it accordingly will be much appreciated.

The simplest way is to define them as 1...N sequentially and then
shuffle them with code to swap a pair chosen at random from the cells
range 1..N run this O(N^2) times and you get what you want.

Regards,
Martin Brown

 

[Paul Black]

See the UDF below.  Use as you would RANDBETWEEN, e.g.
=uniqRandBetween(1,34).

Each uniqRandBetween range has its own pool of unique random numbers.  So
two calls to uniqRandBetween(1,34) will generate a unique pair of numbers;
but a call to uniqRandBetween(1,34) and uniqRandBetween(1,20) might result
in the same random number.

As currently configured, uniqRandBetween supports up to 10 different ranges,
each with a maximum range of 100 values (hi - lo + 1).  Change the Const
variable maxNTabl and maxN as needed.

To enter the UDF, in Excel, press alt+F8 to open the VBA window.  In VBA,
click on Insert, then Module to open a VBE pane.  Copy the text of the UDF
below and paste it into the VBE pane.  You can now close the VBA window..

The UDF....

Option Explicit

Function uniqRandBetween(lo As Long, hi As Long)

'***** customize *****
' maxNtabl = number of lo-to-hi ranges
' maxN = max size of range, hi-lo+1
'******
Const maxNtabl As Long = 10
Const maxN As Long = 100

Static tabl(1 To maxNtabl, 1 To 3 + maxN) As Long
Static ntabl As Long
Dim t As Long, n As Long, x As Long

' find table for lo-to-hi range

If lo > hi Then GoTo retnError
For t = 1 To ntabl
    If tabl(t, 1) = lo And tabl(t, 2) = hi Then GoTo continue
Next
If ntabl >= maxNtabl Then GoTo retnError
If hi - lo + 1 > maxN Then GoTo retnError
ntabl = ntabl + 1
t = ntabl
tabl(t, 1) = lo
tabl(t, 2) = hi
tabl(t, 3) = 0

continue:

' generate list of random numbers, if needed

n = tabl(t, 3)
If n = 0 Then
    For n = 1 To hi - lo + 1
        tabl(t, 3 + n) = lo + n - 1
    Next
    n = n - 1
End If

' generate unique random number.
'
' note:  you might want to change Rnd to
' Evaluate("RAND()") to use Excel RAND.
' slower, but more maybe robust.

x = 1 + Int(n * Rnd)
uniqRandBetween = tabl(t, 3 + x)
If x < n Then tabl(t, 3 + x) = tabl(t, 3 + n)
tabl(t, 3) = n - 1
Exit Function

retnError:

uniqRandBetween = CVErr(xlErrValue)
End Function

Thank you both for the replies.
Unfortunately the UDF produces replica numbers.
What I would prefer is a Sub that produces 5,6,7 or whatever number
combinations without replacement until ALL the numbers have been used.
So for example, if there were 40 numbers and I wanted 6 number
combinations there would be 6 combinations with 6 numbers and 1
combination with 4 numbers so using ALL the 40 numbers only once.
I could then manually change the Sub to meet my future requirements.

Thanks again,
Paul

 

[Paul Black]

Thank you both for the replies.
Unfortunately the UDF produces replica numbers.
What I would prefer is a Sub that produces 5,6,7 or whatever number
combinations without replacement until ALL the numbers have been used.
So for example, if there were 40 numbers and I wanted 6 number
combinations there would be 6 combinations with 6 numbers and 1
combination with 4 numbers so using ALL the 40 numbers only once.
I could then manually change the Sub to meet my future requirements.

Thanks again,
Paul

Actually, this code does what I want other than produce the
combinations until ALL the numbers have been used.
The thing is it resets ALL the numbers before producing the next
combination which is not what I want, I want it to produce
combinations until ALL the numbers have been used only once.

Sub Main()

Dim nDrawnMain As Long ' Total MAIN numbers drawn for each
combination.
Dim nFromMain As Long ' Total MAIN numbers to be drawn from.
Dim nComb As Long ' Total number of random combinations to
be produced.
Dim myMain() As Variant ' MAIN array.

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

nDrawnMain = 7 ' Total MAIN numbers drawn
nFromMain = 34 ' Total MAIN numbers drawn from

Worksheets("Rand").Select

With ActiveSheet
.Columns("A:K").ClearContents ' Clear the current combinations
ready for the new combinations
ReDim myMain(1 To nFromMain) ' Re-dimension the MAIN array
nComb = .Range("N18").Value ' Number of combinations to be
produced
End With

Randomize

For j = 1 To nComb ' Number of random combinations to be produced

' Reinitialize MAIN array before producing a new combination
For h = 1 To nFromMain ' Total numbers to be drawn from
myMain(h) = h
Next h

n = nFromMain ' Total MAIN numbers to be drawn from
For k = 1 To nDrawnMain ' Total MAIN numbers drawn
h = Int(n * Rnd) + 1
Range("B2").Offset(j - 1, k - 1) = myMain(h)
If h <> n Then myMain(h) = myMain(n)
n = n - 1
Next k

Next j

Range("O18").Select

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Thanks again,
Paul

 

[GS]

Paul Black wrote :

Actually, this code does what I want other than produce the
combinations until ALL the numbers have been used.
The thing is it resets ALL the numbers before producing the next
combination which is not what I want, I want it to produce
combinations until ALL the numbers have been used only once.

Sub Main()

Dim nDrawnMain As Long ' Total MAIN numbers drawn for each
combination.
Dim nFromMain As Long ' Total MAIN numbers to be drawn from.
Dim nComb As Long ' Total number of random combinations to
be produced.
Dim myMain() As Variant ' MAIN array.

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

nDrawnMain = 7 ' Total MAIN numbers drawn
nFromMain = 34 ' Total MAIN numbers drawn from

Worksheets("Rand").Select

With ActiveSheet
.Columns("A:K").ClearContents ' Clear the current combinations
ready for the new combinations
ReDim myMain(1 To nFromMain) ' Re-dimension the MAIN array
nComb = .Range("N18").Value ' Number of combinations to be
produced
End With

Randomize

For j = 1 To nComb ' Number of random combinations to be produced

' Reinitialize MAIN array before producing a new combination
For h = 1 To nFromMain ' Total numbers to be drawn from
myMain(h) = h
Next h

n = nFromMain ' Total MAIN numbers to be drawn from
For k = 1 To nDrawnMain ' Total MAIN numbers drawn
h = Int(n * Rnd) + 1
Range("B2").Offset(j - 1, k - 1) = myMain(h)
If h <> n Then myMain(h) = myMain(n)
n = n - 1
Next k

Next j

Range("O18").Select

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Thanks again,
Paul

Try storing the used numbers in a variant and check if your Rnd process
returns a stored number BEFORE adding it to the result.

I'd also store the results in an array and 'dump' it into the wks in
one shot rather than write the wks every iteration of your loop. Doing
the process in memory will ALWAYS be faster than read/write ranges as
you go.<IMO>

What if the number of combinations in Range("N18") is more than the
possible combinations available? You should probably include a check
for that!

 

[GS]

Joe,
Perhaps you could include a variant to store already used numbers and
check each newly generated number to see if it's already been used
BEFORE adding to the result.

 

[Paul Black]

Joe,
Perhaps you could include a variant to store already used numbers and
check each newly generated number to see if it's already been used
BEFORE adding to the result.

--
Garry

Free usenet access athttp://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc

Thanks for the replies Garry.
Actually, the code I posted was mainly conceived by people with far
more knowledge than myself, I still don't fully understand how the
above code works, but it does, so I will have great difficulty in
applying the methods you have kindly put forward.

Kind regards,
Paul

 

[GS]

Paul Black explained :

Thanks for the replies Garry.
Actually, the code I posted was mainly conceived by people with far
more knowledge than myself, I still don't fully understand how the
above code works, but it does, so I will have great difficulty in
applying the methods you have kindly put forward.

Kind regards,
Paul

Paul,
This reply was meant for joeu2004. His code looks like it will work
with my suggestion and so I'm happy to let him revise it to his liking.
Hopefully, he'll get back to you soon.<g>

 

[joeu2004]

It does exactly that if you put =uniqRandBetween(1,34)
into 34 different cells in any arrangement that you wish.
(Previously, you mention 6 rows of 5 and 1 row of 4.)

After populating the 34 cells as your desire, you can generate a new set of
34 unique random values by pressing ctrl+alt+F9.

Alternatively, you could execute the following macro, changing the cell
arrangement as you wish.

Sub genAll()
Dim i as Long, j as Long
Randomize
For i = 1 to 6
For j = 1 to 5
Cells(i,j) = uniqRandBetween(1,34)
Next
Next
For j = 1 to 5
Cells(7,j) = uniqRandBetween(1,34)
Next
End Sub

 

[Paul Black]

After populating the 34 cells as your desire, you can generate a new set of
34 unique random values by pressing ctrl+alt+F9.

Alternatively, you could execute the following macro, changing the cell
arrangement as you wish.

Sub genAll()
Dim i as Long, j as Long
Randomize
For i = 1 to 6
    For j = 1 to 5
       Cells(i,j) = uniqRandBetween(1,34)
    Next
Next
For j = 1 to 5
    Cells(7,j) = uniqRandBetween(1,34)
Next
End Sub

Thanks for your reply Joe.
I have been surfing the web and have come to the conclusion that I
have probably been asking completely the wrong question.
It appears that I need a Sub that "Shuffles" an array.
Unfortunately I can't find one that accommodates exactly what I am
after, which is basically being able to designate the size of the
array (e.g. 34 numbers or 40 numbers or 45 numbers etc) and then
choose whether I want them listed as 4 number combinations, 5 number
combinations or 6 number combinations for example starting in cell
"B2".
If you have any code that does this I would be grateful.

Thanks,
Paul

 

[isabelle]

hello Paul,

do you use excel to do this?
if so, why not use table with "ReDim Preserve"
and check the contents with "Application.Match"
dont forget, you can set a table outside of the macro to maintain content and then change this content.

--
isabelle




Le 2011-09-08 19:07, Paul Black a écrit :

 

[Paul Black]

hello Paul,

do you use excel to do this?
if so, why not use table with "ReDim Preserve"
and check the contents with  "Application.Match"
dont forget, you can set a table outside of the macro to maintain contentand then change this content.

--
isabelle

Le 2011-09-08 19:07, Paul Black a écrit :

- Show quoted text -

Thanks for the reply Isabelle.
Unfortunately my knowledge of VBA is not that great.
I have managed however to put the following code together but
unfortunately it produces the final number 3 times for some reason.
Could you please have a look at it to see what I am doing wrong
please.
Here is the code ...

Sub Shuffle()
Dim Number()

Worksheets("Sheet1").Select

With ActiveSheet
.Columns("A:K").ClearContents
End With

On Error Resume Next

LastNumber = 49

Set ArrayRange = ActiveSheet.Range(Cells(2, 2), Cells(10, 7))

ReDim Number(LastNumber)

For i = 1 To LastNumber
Number(i) = i
Next i

For Each c In ArrayRange
Placement = Int(Rnd() * LastNumber + 1)
c.Value = Number(Placement)
dummy = Number(LastNumber)
Number(LastNumber) = Number(Placement)
Number(Placement) = dummy
LastNumber = LastNumber - 1
Next c

On Error GoTo 0
End Sub

Thanks,
Paul

 

[isabelle]

hi Paul,

Arrayrange is not equal to 49 but 54
you can change this line
LastNumber = 49
for
LastNumber = ActiveSheet.Range (Cells (2, 2), Cells (10, 7)). Count

 

[Paul Black]

hi Paul,

Arrayrange is not equal to 49 but 54
you can change this line
LastNumber = 49
for
LastNumber = ActiveSheet.Range (Cells (2, 2), Cells (10, 7)). Count

--
isabelle

Le 2011-09-09 09:52, Paul Black a crit :













- Show quoted text -

Thanks Isabelle but it still does not work.

Kind regards,
Paul

 

[Paul Black]

Thanks Isabelle but it still does not work.

Kind regards,
Paul- Hide quoted text -

- Show quoted text -

One other thing.
If I do not use the "On Error Resume Next" I get a Run-time error '9',
is this something to do with defining the Array or Variables.

Thanks again,
Paul

 

[Paul Black]

One other thing.
If I do not use the "On Error Resume Next" I get a Run-time error '9',
is this something to do with defining the Array or Variables.

Thanks again,
Paul- Hide quoted text -

- Show quoted text -

Hi Isabelle, I forgot to say the error is on line ...

dummy = Number(LastNumber)

Thanks,
Paul

 

[joeu2004]

Unfortunately my knowledge of VBA is not that great.
I have managed however to put the following code together
but unfortunately it produces the final number 3 times
for some reason.

You almost got it right. A number of small mistakes. Instead of explaining
each one, I suggest that you simply use the macro below.

Instead of putting the macro into a module and relaying on
Worksheets("Sheet1").Select to ensure that the correct worksheet is
modified, I suggest that you put the macro in the worksheet object. That
allows you to rename the worksheet without having to change the macro.

To do that, right-click on the worksheet tab at the bottom of the Excel
window, click on View Code, then copy the macro and paste it into the VBE
pane in the VBA window. Then you can close the VBA window, if you wish.

Programming note.... This is not the most efficient implementation. But
it might be easier to understand as is.

-----

Option Explicit

Sub Shuffle()

' ***** customize*****
Const nMax As Long = 49
Const rAddress As String = "b2:g10"
Const clrAddress As String = "b:k"
' *****

Dim i As Long, j As Long, n As Long
Dim r As Range

' change #If 0 to #If 1 to generate same random
' sequence each time for debugging purposes
#If 0 Then
i = Rnd(-1)
Randomize 1
#Else
Randomize
#End If

Set r = Range(rAddress)

' clear any previous data
Columns(clrAddress).ClearContents

' generate up to nMax random numbers.
' generate fewer if range is smaller than nMax
n = IIf(nMax <= r.Count, nMax, r.Count)

' initialize set of random numbers, 1 to nMax
ReDim num(1 To n) As Long
For i = 1 To n: num(i) = i: Next

For i = 1 To n
' generate next random number.
' store into range, across columns,
' then down rows
j = 1 + Int(n * Rnd())
r(i) = num(j)

' remove num(j) from set of random numbers
If j < n Then num(j) = num(n)
n = n - 1
Next

End Sub

 

[Paul Black]

You almost got it right.  A number of small mistakes.  Instead of explaining
each one, I suggest that you simply use the macro below.

Instead of putting the macro into a module and relaying on
Worksheets("Sheet1").Select to ensure that the correct worksheet is
modified, I suggest that you put the macro in the worksheet object.  That
allows you to rename the worksheet without having to change the macro.

To do that, right-click on the worksheet tab at the bottom of the Excel
window, click on View Code, then copy the macro and paste it into the VBE
pane in the VBA window.  Then you can close the VBA window, if you wish..

Programming note....   This is not the most efficient implementation.  But
it might be easier to understand as is.

-----

Option Explicit

Sub Shuffle()

' ***** customize*****
Const nMax As Long = 49
Const rAddress As String = "b2:g10"
Const clrAddress As String = "b:k"
' *****

Dim i As Long, j As Long, n As Long
Dim r As Range

' change #If 0 to #If 1 to generate same random
' sequence each time for debugging purposes
#If 0 Then
    i = Rnd(-1)
    Randomize 1
#Else
    Randomize
#End If

Set r = Range(rAddress)

' clear any previous data
Columns(clrAddress).ClearContents

' generate up to nMax random numbers.
' generate fewer if range is smaller than nMax
n = IIf(nMax <= r.Count, nMax, r.Count)

' initialize set of random numbers, 1 to nMax
ReDim num(1 To n) As Long
For i = 1 To n: num(i) = i: Next

For i = 1 To n
    ' generate next random number.
    ' store into range, across columns,
    ' then down rows
    j = 1 + Int(n * Rnd())
    r(i) = num(j)

    ' remove num(j) from set of random numbers
    If j < n Then num(j) = num(n)
    n = n - 1
Next

End Sub

Hi Joe, excellent, THANK YOU.
I will go through your code and get a better understanding of what is
happening.

Kind regards,
Paul

 

[Paul Black]

Hi Joe, excellent, THANK YOU.
I will go through your code and get a better understanding of what is
happening.

Kind regards,
Paul

Hi Joe,

I am going to run the program off of a button on the Worksheet.
I have tried to adapt the code slightly to have two input boxes pop up
initially, the first asking the maximum number to be Randomized and
the second to ask how many numbers there are in each combination. I
have achieved the first one but I can't work out how to achieve the
second one. Any advice would be appreciated, but if it is too
complicated or time consuming then not to worry.
Thank you for the time and effort on getting me this far. it is
apprciated.

Here is the code ...

Option Explicit
Sub Shuffle()
' ***** customize *****
' Const nMax As Long = 49
Const rAddress As String = "b2:g50"
Const clrAddress As String = "b:k"
Dim nFrom As Long
Dim nDrawn As Long
' *****

Dim i As Long, j As Long, n As Long
Dim r As Range

'
****************************************************************************************************************************
nFrom = Application.InputBox("How Many Numbers Would You Like To
Randomize?", "Shuffle Size", Type:=1)
nDrawn = Application.InputBox("How Many Numbers In Each Combination?",
"Combination Size", Type:=1)
'
****************************************************************************************************************************

' change #If 0 to #If 1 to generate same random
' sequence each time for debugging purposes
#If 0 Then
i = Rnd(-1)
Randomize 1
#Else
Randomize
#End If

Set r = Range(rAddress)

' clear any previous data
Columns(clrAddress).ClearContents

' generate up to nMax random numbers.
' generate fewer if range is smaller than nMax
n = IIf(nFrom <= r.Count, nFrom, r.Count)

' initialize set of random numbers, 1 to nMax
ReDim num(1 To n) As Long
For i = 1 To n: num(i) = i: Next

For i = 1 To n
' generate next random number.
' store into range, across columns,
' then down rows
j = 1 + Int(n * Rnd())
r(i) = num(j)

' remove num(j) from set of random numbers
If j < n Then num(j) = num(n)
n = n - 1
Next
End Sub

Kind regards,
Paul