Max said:
Great sub, Leo !
Is there a simple way to bring over to Excel screen via say, an inputbox,
so
that we can define the clickable ranges and the numeric limits below in
Excel
itself ?
Thanks Max!
Here's ver.2 with more options.
The Rand data is now set up in a named table in the proper worksheet(s).
The random numbers are still fetched by doubleclicking a cell, but you now
have a choice of filling one cell or all cells.
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.
For example my named range is H2:L12 (H1:L1 contains headings).
Not all rows in the range need to be filled, but blank rows must not exist
between filled rows. H2:L6 could contain definitions with empty cells in
H7:L12, which is OK.
H2:L6 and H9:L9 containing definitions and H7:L8 being empty is
not allowed.
The table has 5 columns with these headings:
Column 1: Range
Column 2: First number
Column 3: Last number
Column 4: Step
Column 5: All cells
Examples:
B2:B6 2 60 2 yes
G20:K100 5 1000 3
B2:B6 will be filled with even numbers in the range 2 - 60 (inclusive).
Step 2 means, that the random 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. If the cell in column 5 is empty, a click will only
fill the clicked cell.
The "yes" could have been anything (true, 1 etc). As long as the cell
is *not empty*, all cells in the range will be filled immediately.
The second example has a pool of random numbers consisting of
5,8,11,14,17,.........
Doubleclicking a cell in G20:K100 will only fill this cell.
Doubleclicking a filled cell, will ask you, if you want a new number(s).
There's no limit to the number of RandRanges.
The below sub "Worksheet_BeforeDoubleClick" is inserted by copying
the code, rightclicking the sheet tab and paste to the righthand window.
The same code can be inserted from more sheets at the same time.
The important thing is, that the RandTables are named *locally* as
described above.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
'Leo Heuser, 20 Sep. 2006, ver. 2
Dim Answer As Variant
Dim Cell As Range
Dim Counter As Long
Dim Counter1 As Long
Dim DummyRange As Range
Dim RandData As Variant
Dim RandRange As Range
Dim RandTableRange As Range
Dim RandTableValue As Variant
Dim RandTableName As String
RandTableName = "RandTable"
Set RandTableRange = Range(ActiveSheet.Name & "!" & RandTableName)
Set RandTableRange = RandTableRange. _
Resize(Application.CountA(RandTableRange.Columns(1)))
RandData = RandTableRange.Value
For Counter = LBound(RandData, 1) To UBound(RandData, 1)
Set RandRange = Range(RandData(Counter, 1))
If Not Intersect(Target, RandRange) Is Nothing Then
If Target.Cells.Count > 1 Then Exit Sub
Cancel = True
If Not (IsEmpty(Target)) Then
Answer = MsgBox("Do you want a new random number(s)?", _
vbDefaultButton2 + vbYesNo)
If Answer <> vbYes Then Exit Sub
End If
If IsEmpty(RandData(Counter, 5)) Then
Set DummyRange = Target
Else
RandRange.ClearContents
Set DummyRange = RandRange
End If
For Each Cell In DummyRange.Cells
Cell.Value = NewRandNum(RandRange, _
RandData(Counter, 2), _
RandData(Counter, 3), _
RandData(Counter, 4))
Next Cell
Exit Sub
End If
Next Counter
End Sub
The code below is inserted in a general module.
(<Alt><F11>, Insert > Module)
Function NewRandNum(RandRange As Range, FirstNum As Variant, _
LastNum As Variant, StepValue As Variant) As Variant
'Leo Heuser, 20 Sep. 2006, ver. 2
'When a number is inserted in a cell, it's not updated ever,
'and it is removed from the random number pool of that range.
'If a number is deleted from a cell, it's automatically added
'to the pool of that range.
Dim Counter As Double
Dim Counter1 As Long
Dim RandCol As New Collection
Dim RandNum As Long
Dim RandRangeValue As Variant
Randomize
RandRangeValue = RandRange.Value
On Error Resume Next
If LastNum < FirstNum Then
StepValue = -Abs(StepValue)
Else
StepValue = Abs(StepValue)
End If
For Counter = FirstNum To LastNum Step StepValue
RandCol.Add Item:=Counter, key:=CStr(Counter)
Next Counter
For Counter = 1 To UBound(RandRangeValue, 1)
For Counter1 = 1 To UBound(RandRangeValue, 2)
If Not (IsEmpty(RandRangeValue(Counter, Counter1))) Then
RandCol.Add Item:=RandRangeValue(Counter, Counter1), _
key:=CStr(RandRangeValue(Counter, Counter1))
If Err.Number <> 0 Then
RandCol.Remove _
CStr(RandRangeValue(Counter, Counter1))
Err.Number = 0
End If
End If
Next Counter1
Next Counter
RandNum = Int(Rnd() * RandCol.Count) + 1
NewRandNum = RandCol(RandNum)
On Error GoTo 0
End Function
Cheers
Leo
