Here's a tweak on one of Tom Ogilvy's routines, that will prompt you for how
many sets of numbers you want and how many numbers within each set. It's
currently set for values between 1 to 49 ( Yes it was a lottery draw :-> ), and
will not give any duplicates in any one set. To change the set of numbers it
pulls from just replace the 1 with your starting number and the 49 with your
finishing, and the 50 with 'your finishing number + 1':-
Option Explicit
Sub DrawNumbers()
'If you want unique random numbers, i.e. you want to shuffle the numbers 1 to 49
'
Dim i, choice, balls(1 To 49)
Dim lngArr(1 To 49) As Long
Dim RwNdx1 As Long
Dim RwNdx2 As Long
Dim ColNdx As Long
Dim ColW As Long
Dim lrow As Long
Dim cnt1 As Long
Dim cnt2 As Long
Dim temp As Long
Dim Rng As Range
Dim ar As Range
Dim cell As Range
ColW = ActiveSheet.UsedRange.Column - 1 + _
ActiveSheet.UsedRange.Columns.Count
lrow = ActiveSheet.UsedRange.Row - 1 + _
ActiveSheet.UsedRange.Rows.Count
' Clear the existing data first
Range("A1", Cells(lrow, ColW)).ClearContents
Range("A1").Select
cnt1 = InputBox("How many sets of numbers do you want?")
cnt2 = InputBox("How many numbers in each set do you want?")
If cnt2 > 49 Then
MsgBox ("You have asked for more numbers than you are pulling from - Try
again")
Call DrawNumbers
End If
RwNdx1 = 2
RwNdx2 = cnt2 + 1
For ColNdx = 1 To cnt1
Randomize
For i = 1 To 49
balls(i) = i
Next
For i = 1 To 49
choice = 1 + Int((Rnd * (49 - i)))
temp = balls(choice)
balls(choice) = balls(50 - i)
balls(50 - i) = temp
Next
i = 0
With Cells(RwNdx1 - 1, ColNdx)
.Value = "Set" & ColNdx
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
Set Rng = Range(Cells(RwNdx1, ColNdx), Cells(RwNdx2, ColNdx))
For Each ar In Rng
For Each cell In ar
i = i + 1
cell.Value = balls(i)
Next
Next
Next ColNdx
Range("A1").Select
End Sub
