Non updatable Unique Random Number

Hi Ian

My fault. You probably have a sheet name with
one or more spaces.
I forgot to include apostrophes in the code.
I have the final (? :-) version ready tomorrow, so please watch
the thread.

Regards
Leo Heuser


"Ian" skrev i en meddelelse
...
Hi Leo,

Thanks for a great solution, just what i was looking for, however, I've
hit
a bit of a problem and my VBA skills aren't good enough to determine the
problem.

I copied your code, as per instructions, into a new workbook and it
worked a
dream. Confident in my own limited skills I went to my workbook where I
wanted the origianl random numbers and repeated the process. Failure, I
can't
get past the following error message:

Runtime error '1004': Method 'Range' of object '_Worksheet' failed.

When I click Debug the following line of code is highlighted:

Set RandTableRange = Range(ActiveSheet.Name & "!" & RandTableName)

The "RandTable" is on the local worksheet as you suggest (Sheet10 in my
case), in fact I did no more than when I got it working in a new
workbook.

Is there something blindingly obvious I have missed?

Thanks in advance,
Ian.

"Leo Heuser" wrote:
.. I have the final (? :-) version ready tomorrow,
so please watch the thread.

Just to let on that I'm watching, Leo g.
Look forward to it ..
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---

"Ian" skrev i en meddelelse
...
Hi Leo,

Thanks for a great solution, just what i was looking for, however, I've
hit
a bit of a problem and my VBA skills aren't good enough to determine the
problem.

I copied your code, as per instructions, into a new workbook and it
worked a
dream. Confident in my own limited skills I went to my workbook where I
wanted the origianl random numbers and repeated the process. Failure, I
can't
get past the following error message:

Runtime error '1004': Method 'Range' of object '_Worksheet' failed.

When I click Debug the following line of code is highlighted:

Set RandTableRange = Range(ActiveSheet.Name & "!" & RandTableName)

The "RandTable" is on the local worksheet as you suggest (Sheet10 in my
case), in fact I did no more than when I got it working in a new
workbook.

Is there something blindingly obvious I have missed?

Thanks in advance,
Ian.

Hi Ian (and Max :-)

Glad you could use it!

Here's version 3.0 with two more options. You have a choice of having
duplicates in the pool, and the range for the random numbers can concist
of non-contiguous areas. Please notice, that the sub "...BeforeDoubleclick"
is now inserted in "ThisWorkbook".

A.
The Rand data is set up in a named table in the proper worksheet(s).
The headings are *not* part of the name!

For example a named table could be H2:M12 (H1:M1 containing headings).

The name must be "RandTable" (without quotes) and it must be local, so
in sheet1 the name is sheet1!RandTable, in sheet2 the name is
sheet2!RandTable etc. Use Insert Name Define.

If you prefer another standard name for you RandTables, you must
edit the following line in "Workbook_SheetBeforeDoubleClick":

Const RAND_TABLE_NAME As String = "RandTable"

If you have spaces in a sheet name, the sheet name must be enclosed
in apostrophes (single quotes) like: 'Random numbers'!RandTable.

An idea is to use the underline character _ instead of space in
sheet names. The readability is the same, and you will never need to
use apostrophes in sheet names again.

If you doubleclick a sheet tab to rename the sheet, it's not necessary
to use single quotes. Excel does it for you.

B.

"Leo Heuser" wrote:
.. Here's version 3.0 with two more options. You have a choice of having
duplicates in the pool, and the range for the random numbers can consist
of non-contiguous areas ..

Magnificent, Leo! A classic.

Very fast populating of large ranges
(eg: 10k unique rand nos within a 1000R x 10C grid in 5 secs!).

Just some thoughts on this new prompt encountered:
"Too few numbers in the pool"
for example when I tried it with the settings below
(where the range exceeds the no. of unique numbers)

Range: A31:F38 (a 8R x 6C grid)
First no.: 1
Last no.: 45
Stepval: 1
All cells: yes
Duplicates: No

Your previous ver2 would simply random fill the first 7 rows, and half of
the last 8th row in a zig-zag, left to right manner, leaving the last 3 cells
D38:F38 empty. Could this option / feature be somehow retained, as an
alternative perhaps to "Proceed nonetheless" ? To get it running similarly in
ver3, I'd need to re-define the range as say: A31:F37, A38:C38 (albeit with
ver3's discontiguous ranges allowed, I could now define / choose exactly
where the last 3 cells should be populated). Thanks.
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---

"Max" skrev i en meddelelse
...
"Leo Heuser" wrote:
.. Here's version 3.0 with two more options. You have a choice of having
duplicates in the pool, and the range for the random numbers can consist
of non-contiguous areas ..

Magnificent, Leo! A classic.

Very fast populating of large ranges
(eg: 10k unique rand nos within a 1000R x 10C grid in 5 secs!).

Just some thoughts on this new prompt encountered:
"Too few numbers in the pool"
for example when I tried it with the settings below
(where the range exceeds the no. of unique numbers)

Range: A31:F38 (a 8R x 6C grid)
First no.: 1
Last no.: 45
Stepval: 1
All cells: yes
Duplicates: No

Your previous ver2 would simply random fill the first 7 rows, and half of
the last 8th row in a zig-zag, left to right manner, leaving the last 3
cells
D38:F38 empty. Could this option / feature be somehow retained, as an
alternative perhaps to "Proceed nonetheless" ? To get it running similarly
in
ver3, I'd need to re-define the range as say: A31:F37, A38:C38 (albeit
with
ver3's discontiguous ranges allowed, I could now define / choose exactly
where the last 3 cells should be populated). Thanks.
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---

Hi Max

Thanks for the nice words and your interest in the project!

Here is ver. 3.1 with the alternative. I also managed
to catch a couple of bloopers on the way g.

The "ThisWorkbook" routine ver. 3.0 still holds.

Best regards
Leo




Sub GetRandNum(Target As Range, RandRange As Range, _
RandTableRange As Range, RandTableRow As Long)
'Leo Heuser, 26 Sep. 2006, ver. 3.1
'When a number is inserted in a cell, it's never updated,
'and it is removed from the number pool of that range.
'If a cell is cleared, the cleared number is added to the
'pool of that range.

Dim AllCells As Boolean
Dim Answer As Variant
Dim AnswerText As String
Dim CountAreas As Long
Dim CountCol As Double
Dim Counter As Long
Dim Counter1 As Long
Dim DupliCates As Boolean
Dim FirstNum As Double
Dim LastNum As Double
Dim NumAreas As Long
Dim RandCol As New Collection
Dim RandArray() As Variant
Dim RandNum As Long
Dim RandRangeValue() As Variant
Dim RandTableValue As Variant
Dim StepValue As Double
Dim YesChoice As Variant

Randomize

YesChoice = Array("x", 1, "yes", True) ' Case doesn't matter

NumAreas = RandRange.Areas.Count

ReDim RandRangeValue(1 To NumAreas)

On Error GoTo Finito

RandTableValue = RandTableRange.Value

FirstNum = RandTableValue(RandTableRow, 2)
LastNum = RandTableValue(RandTableRow, 3)

If IsEmpty(RandTableValue(RandTableRow, 4)) Then
StepValue = 1
Else
StepValue = RandTableValue(RandTableRow, 4)
End If

If LastNum FirstNum Then
StepValue = -Abs(StepValue)
Else
StepValue = Abs(StepValue)
End If

If Not IsError(Application. _
Match(RandTableValue(RandTableRow, 5), YesChoice, 0)) Then
AllCells = True
Else
AllCells = False
End If

If Not IsError(Application. _
Match(RandTableValue(RandTableRow, 6), YesChoice, 0)) Then
DupliCates = True
Else
DupliCates = False
End If

If AllCells Then
If Application.CountA(RandRange) 0 Then
AnswerText = "Do you want a new set of random numbers "
Answer = MsgBox(AnswerText, _
vbDefaultButton2 + vbYesNo)
If Answer vbYes Then GoTo Finito
End If

If Not DupliCates Then
If (LastNum - FirstNum) / StepValue + 1 _
RandRange.Cells.Count Then
AnswerText = "Too few numbers to fill the entire range."
AnswerText = AnswerText & vbNewLine & _
"Proceed nonetheless?"
Answer = MsgBox(AnswerText, vbDefaultButton2 + vbYesNo)

If Answer vbYes Then GoTo Finito
End If
End If

RandRange.ClearContents
Else
If Not DupliCates Then
If (LastNum - FirstNum) / StepValue + 1 = _
Application.CountA(RandRange) Then
MsgBox "All numbers have been used."
GoTo Finito
End If
End If

If Not (IsEmpty(Target)) Then
Answer = MsgBox("Do you want a new random number?", _
vbDefaultButton2 + vbYesNo)
If Answer vbYes Then GoTo Finito
End If
End If

For Counter = 1 To RandRange.Areas.Count
RandRangeValue(Counter) = RandRange.Areas(Counter).Value
Next Counter

On Error Resume Next

For CountCol = FirstNum To LastNum Step StepValue
RandCol.Add Item:=CountCol, key:=CStr(CountCol)
Next CountCol

If AllCells Then
For CountAreas = 1 To NumAreas
If RandRange.Areas(CountAreas).Cells.Count = 1 Then
RandNum = Int(Rnd() * RandCol.Count) + 1
If RandCol.Count 0 Then
RandRange.Areas(CountAreas).Value = RandCol(RandNum)
If Not (DupliCates) Then RandCol.Remove RandNum
Else
RandRange.Areas(CountAreas).Value = Empty
End If
Else

ReDim RandArray(1 To UBound(RandRangeValue(CountAreas), 1), _
1 To UBound(RandRangeValue(CountAreas), 2))

For Counter = 1 To UBound(RandRangeValue(CountAreas), 1)
For Counter1 = 1 To UBound(RandRangeValue(CountAreas), 2)
RandNum = Int(Rnd() * RandCol.Count) + 1
If RandCol.Count 0 Then
RandArray(Counter, Counter1) = RandCol(RandNum)
If Not (DupliCates) Then RandCol.Remove RandNum
Else
RandArray(Counter, Counter1) = Empty
End If
Next Counter1
Next Counter

RandRange.Areas(CountAreas).Value = RandArray
End If
Next CountAreas
Else
If Not (DupliCates) Then
For CountAreas = 1 To NumAreas
If RandRange.Areas(CountAreas).Cells.Count = 1 Then
If Not (IsEmpty(RandRangeValue(CountAreas))) Then
RandCol.Add Item:= _
RandRangeValue(CountAreas), _
key:=CStr(RandRangeValue(CountAreas))

If Err.Number 0 Then
RandCol.Remove CStr(RandRangeValue(CountAreas))
Err.Number = 0
End If
End If
Else
For Counter = 1 To UBound(RandRangeValue(CountAreas), 1)
For Counter1 = 1 To UBound(RandRangeValue(CountAreas), 2)
If Not (IsEmpty(RandRangeValue(CountAreas)(Counter, _
Counter1))) Then
RandCol.Add Item:= _
RandRangeValue(CountAreas)(Counter, Counter1), _
key:=CStr(RandRangeValue(CountAreas)(Counter, Counter1))

If Err.Number 0 Then
RandCol.Remove _
CStr(RandRangeValue(CountAreas)(Counter, Counter1))
Err.Number = 0
End If
End If
Next Counter1
Next Counter
End If
Next CountAreas
End If

On Error GoTo Finito

RandNum = Int(Rnd() * RandCol.Count) + 1
Target.Value = RandCol(RandNum)
End If

Finito:
If Err.Number 0 Then
MsgBox "Unexpected error." & vbNewLine & Err.Description
End If

On Error GoTo 0

End Sub

Ahh, excellent! Just the way I wanted it served g
Many thanks, Leo ! cheers
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---
"Leo Heuser" wrote:
Hi Max

Thanks for the nice words and your interest in the project!

Here is ver. 3.1 with the alternative. I also managed
to catch a couple of bloopers on the way g.

The "ThisWorkbook" routine ver. 3.0 still holds.

Best regards
Leo

Bon appétit, Max g

Cheers
Leo


"Max" skrev i en meddelelse
...
Ahh, excellent! Just the way I wanted it served g
Many thanks, Leo ! cheers
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---
"Leo Heuser" wrote:
Hi Max

Thanks for the nice words and your interest in the project!

Here is ver. 3.1 with the alternative. I also managed
to catch a couple of bloopers on the way g.

The "ThisWorkbook" routine ver. 3.0 still holds.

Best regards
Leo

My compliments to the chef g
Truly fine cuisine ..
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---
"Leo Heuser" wrote in message
...
Bon appétit, Max g

Cheers
Leo

Hi Leo,

Many apologies for the delay in replying to the v3 project you posted, I've
just implemented your upgrade and it works great. I've come back to the forum
and notice v3.1 now posted which I will duly upgrade to.

This has proved a very popular thread and has got me thinking of other uses
for this random number generation. I tried to populate a 31 day calender with
a work duty roster using the number of staff (11) in our department and
thought that if I selected "Yes" to duplicates it would fill the range
anyhow. This doesn't seem to be the case as the message is not enough numbers
in the pool. How easy would it be to fill a range with a set of numbers
smaller than the range even if duplicates is selected?

I'd like to thank you for all your code samples in reply to my initial
question, you have truly "stepped up to the plate". If my last suggestion is
seen as being too cheeky, please tell me to clear off and read the books!!

Thanks again Leo for all your hard work,
Ian.

"Leo Heuser" wrote:

"Ian" skrev i en meddelelse
...
Hi Leo,

Thanks for a great solution, just what i was looking for, however, I've
hit
a bit of a problem and my VBA skills aren't good enough to determine the
problem.

I copied your code, as per instructions, into a new workbook and it
worked a
dream. Confident in my own limited skills I went to my workbook where I
wanted the origianl random numbers and repeated the process. Failure, I
can't
get past the following error message:

Runtime error '1004': Method 'Range' of object '_Worksheet' failed.

When I click Debug the following line of code is highlighted:

Set RandTableRange = Range(ActiveSheet.Name & "!" & RandTableName)

The "RandTable" is on the local worksheet as you suggest (Sheet10 in my
case), in fact I did no more than when I got it working in a new
workbook.

Is there something blindingly obvious I have missed?

Thanks in advance,
Ian.

Hi Ian (and Max :-)

Glad you could use it!

Here's version 3.0 with two more options. You have a choice of having
duplicates in the pool, and the range for the random numbers can concist
of non-contiguous areas. Please notice, that the sub "...BeforeDoubleclick"
is now inserted in "ThisWorkbook".

A.
The Rand data is set up in a named table in the proper worksheet(s).
The headings are *not* part of the name!

For example a named table could be H2:M12 (H1:M1 containing headings).

The name must be "RandTable" (without quotes) and it must be local, so
in sheet1 the name is sheet1!RandTable, in sheet2 the name is
sheet2!RandTable etc. Use Insert Name Define.

If you prefer another standard name for you RandTables, you must
edit the following line in "Workbook_SheetBeforeDoubleClick":

Const RAND_TABLE_NAME As String = "RandTable"

If you have spaces in a sheet name, the sheet name must be enclosed
in apostrophes (single quotes) like: 'Random numbers'!RandTable.

An idea is to use the underline character _ instead of space in
sheet names. The readability is the same, and you will never need to
use apostrophes in sheet names again.

If you doubleclick a sheet tab to rename the sheet, it's not necessary
to use single quotes. Excel does it for you.

B.
The random numbers are fetched by doubleclicking a cell in one of the
defined ranges in column 1 (see below). If a cell(s) is cleared, the
number(s) in the cell(s) is returned to the pool.

C.
The RandTable has 6 columns with these headings:
Column 1: Range
Column 2: First number
Column 3: Last number
Column 4: Stepvalue
Column 5: All cells
Column 6: Duplicates

Column 1: References to the various ranges receiving random numbers
from the matching pool.
Entered as "b3:b2000", "c4:F45" , "Block1" etc. without quotes.

Non-contiguous ranges are supported. The references can be
entered with comma or semicolon as delimiter, e.g. "b3:g14;h2:h40" or
"f3,h3,k5,m5" (without quotes) or named ranges. Block1 above could concist
of 2, 3 or more non-contiguous ranges.

Column 2 and 3: Positive and/or negative integers, 0 and decimal numbers.

Column 4: If empty, a stepvalue of 1 (or -1) is assumed, else as column 2
and 3.
The stepvalue is added (or subtracted) to the first number to get the next
number in the random number pool. Then stepvalue is used on the new
number and so on.

Column 5: If a "yes-choice" (see later) is entered, all cells are filled
with one stroke. For all other entries (including an empty cell) a number
is inserted in the active cell (single-cell mode).

Column 6: If a "yes-choice" (see later) is entered, duplicates are allowed
in the pool. For all other entries (including an empty cell) duplicates are
not used.

Don't edit "First number", "Last number" and/or "Stepvalue" in single-cell
mode until you have cleared the range first!!


D.
Examples:

Range First number Last number Stepvalue All cells Duplicates
B2:B6 2 60 2 yes x
G20:K100 5 1000 3
A2,C2,E2 1 7


In the first example the pool of numbers for B2:B6 will be filled with
even numbers in the range 2 - 60 (inclusive).
Stepvalue 2 means, that the numbers will be 2,4,6,8,10,.....,60.
The "yes" in column 5 means, that doubleclicking a cell in B2:B6 will
fill all cells at once. The "x" in column 6 means that duplicates are
allowed in the pool.

The second example has a pool of numbers consisting of
5,8,11,14,17,.........
Doubleclicking a cell in G20:K100 will only fill this cell.

The third example shows a non-contiguous range consisting of 3 cells
with this pool of the numbers 1, 2, 3, 4, 5, 6 og 7.

Doubleclicking a filled cell in single-cell mode will bring up a message
box asking you, if you want a new random number in the cell.

In "AllCells" mode, doubleclicking a cell (filled or not) will ask you,
if you want the entire range to be filled with new random numbers.

There's no limit to the number of RandTables and they can reside
in one or more sheets, but each table only works for ranges in the
same sheet. The important thing is, that it's given a local name as
described above.

E:
The below sub "Workbook_SheetBeforeDoubleClick" is inserted by
copying the code, going to the VBA-editor with AltF11, double-
clicking "ThisWorkbook" for the project in the project window (at the
left of the screen. If not visible press Ctrlr) and paste to the righthand
window.


Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, _
ByVal Target As Range, Cancel As Boolean)
'Leo Heuser, 23 Sep. 2006, ver. 3.0

Const RAND_TABLE_NAME As String = "RandTable"

Dim Counter As Long
Dim RandData As Variant
Dim RandRange As Range
Dim RandTableRow As Long
Dim RandTableRange As Range

On Error Resume Next

Set RandTableRange = Range("'" & ActiveSheet.Name & "'!" & _
RAND_TABLE_NAME)

If Err.Number 0 Then
Err.Number = 0
GoTo Finito
End If

On Error GoTo Finito

RandData = RandTableRange.Value

For Counter = LBound(RandData, 1) To UBound(RandData, 1)
If Not IsEmpty(RandData(Counter, 1)) Then
Set RandRange = _
Range(Replace(RandData(Counter, 1), ";", ","))
If Not Intersect(Target, RandRange) Is Nothing Then
If Target.Cells.Count 1 Then GoTo Finito

RandTableRow = Counter
Cancel = True

On Error GoTo 0

Call GetRandNum(Target, RandRange, _
RandTableRange, RandTableRow)

Exit For
End If
End If
Next Counter

Finito:
If Err.Number 0 Then
MsgBox "Unexpected error." & vbNewLine & Err.Description
End If

On Error GoTo 0

End Sub



F:
The sub "GetRandNum" is inserted in a standard module.
Copy the code below. In the VBA editor choose Insert Module,
and paste into the righthand window.

In the line

YesChoice = Array("x", 1, "yes", True) ' Case doesn't matter

you can add your own "Yes"-choices.

"True" means, that the user can enter the local equivalent to
TRUE in the RandTable, if you work in a localised version of Excel.
In Danish it is SAND, in German WAHR, in French VRAI etc.


Sub GetRandNum(Target As Range, RandRange As Range, _
RandTableRange As Range, RandTableRow As Long)
'Leo Heuser, 23 Sep. 2006, ver. 3.0
'When a number is inserted in a cell, it's never updated,
'and it is removed from the number pool of that range.
'If a number is deleted from a cell, it's automatically added
'to the pool of that range.

Dim AllCells As Boolean
Dim Answer As Variant
Dim AnswerText As String
Dim CountAreas As Long
Dim CountCol As Double
Dim Counter As Long
Dim Counter1 As Long
Dim DupliCates As Boolean
Dim FirstNum As Double
Dim LastNum As Double
Dim NumAreas As Long
Dim RandCol As New Collection
Dim RandArray() As Double
Dim RandNum As Long
Dim RandRangeValue() As Variant
Dim RandTableValue As Variant
Dim StepValue As Double
Dim YesChoice As Variant

Randomize

YesChoice = Array("x", 1, "yes", True) ' Case doesn't matter

NumAreas = RandRange.Areas.Count

ReDim RandRangeValue(1 To NumAreas)

On Error GoTo Finito

RandTableValue = RandTableRange.Value

FirstNum = RandTableValue(RandTableRow, 2)
LastNum = RandTableValue(RandTableRow, 3)

If IsEmpty(RandTableValue(RandTableRow, 4)) Then
StepValue = 1
Else
StepValue = RandTableValue(RandTableRow, 4)
End If

If LastNum FirstNum Then
StepValue = -Abs(StepValue)
Else
StepValue = Abs(StepValue)
End If

If (LastNum - FirstNum) / StepValue + 1 _
RandRange.Cells.Count Then
MsgBox "Too few numbers in the pool."
GoTo Finito
End If

If Not IsError(Application. _
Match(RandTableValue(RandTableRow, 5), YesChoice, 0)) Then
AllCells = True
Else
AllCells = False
End If

If Not IsError(Application. _
Match(RandTableValue(RandTableRow, 6), YesChoice, 0)) Then
DupliCates = True
Else
DupliCates = False
End If

If AllCells Then
If Application.CountA(RandRange) 0 Then
AnswerText = "Do you want new random numbers "

Hi Ian


"Ian" skrev i en meddelelse
...
Hi Leo,

Many apologies for the delay in replying to the v3 project you posted,
I've
just implemented your upgrade and it works great. I've come back to the
forum
and notice v3.1 now posted which I will duly upgrade to.

This has proved a very popular thread and has got me thinking of other
uses
for this random number generation. I tried to populate a 31 day calender
with
a work duty roster using the number of staff (11) in our department and
thought that if I selected "Yes" to duplicates it would fill the range
anyhow. This doesn't seem to be the case as the message is not enough
numbers
in the pool. How easy would it be to fill a range with a set of numbers
smaller than the range even if duplicates is selected?


Max beat you to it g . It has been implemented in v3.1.



I'd like to thank you for all your code samples in reply to my initial
question, you have truly "stepped up to the plate". If my last suggestion
is
seen as being too cheeky, please tell me to clear off and read the books!!

Thanks again Leo for all your hard work,
Ian.

You are welcome, Ian, and thanks for your positive feedback!


Regards
Leo Heuser