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 <Alt><F11>, double-
clicking "ThisWorkbook" for the project in the project window (at the
left of the screen. If not visible press <Ctrl>r) 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 "
AnswerText = AnswerText & "in the entire range?"
Answer = MsgBox(AnswerText, _
vbDefaultButton2 + vbYesNo)
If Answer <> vbYes Then GoTo Finito
RandRange.ClearContents
End If
Else
If Not (IsEmpty(Target)) Then
If (LastNum - FirstNum) / StepValue + 1 = _
Application.CountA(RandRange) Then
MsgBox "All numbers have been used."
GoTo Finito
Else
Answer = MsgBox("Do you want a new random number?", _
vbDefaultButton2 + vbYesNo)
If Answer <> vbYes Then GoTo Finito
End If
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
RandRange.Areas(CountAreas).Value = RandCol(RandNum)
If Not (DupliCates) Then RandCol.Remove RandNum
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
RandArray(Counter, Counter1) = RandCol(RandNum)
If Not (DupliCates) Then RandCol.Remove RandNum
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
Please let me know, if any malfunctions pop up.
Happy randomizing <g>
Regards
Leo Heuser
