Sub Lotto()
'10 Draws lots from values in a table finding 7 different past numbers.
'If a number occurs in the table more than once, the probability
'increases for this number to become a winner.
Dim lVal As Long
Dim rInput As Range
Dim rCell As Range
Dim colCheck As Collection
Dim colWinners As Collection
On Error GoTo ErrorHandle
'We assume that the table is on the first worksheet and starts in cell A1.
'The range, rInput is set = the table.
Set rInput = Worksheets(1).Range("A1").CurrentRegion
'Checks that there are at least 8 cells in the table.
If rInput.Count < 8 Then
MsgBox "There are too few cells in the table.", vbCritical
GoTo BeforeExit
End If
'Checks that the table contains numbers only and no empty cells.
For Each rCell In rInput
If IsNumeric(rCell.Value) = False Or Len(rCell.Value) = 0 Then
MsgBox "The cells must be numbers.", vbCritical
GoTo BeforeExit
End If
Next
On Error Resume Next
'Checks that there are at least 8 different values.
'This is done by adding the numbers to a collection
'as Keys. Collections will only accept unique keys,
'and "On Error Resume Next" (above) ensures that
'the program doesn't crash with an error, if a
'duplicate Key is added.
Set colCheck = New Collection
For Each rCell In rInput
With rCell
'The number is converted to an Integer and
'a String, before being used as a Key.
colCheck.Add Int(.Value), Str$(Int(.Value))
End With
'The loop stops, when there are
'8 different values in colCheck.
If colCheck.Count = 10 Then Exit For
Next
'If there are not 8 different values in the table, we exit.
If colCheck.Count < 10 Then
MsgBox "There must be at least 8 different values in the table."
GoTo BeforeExit
End If
Set colWinners = New Collection
'Resets the number generator, so it gets a new
'seed value from the computer's clock.
'About seed values see: http://en.wikipedia.org/wiki/Random_seed
Randomize
'We now find 7 random numbers between 1 and the number of
'cells in the table. The value in the cell with the
'corresponding item number in rInput is added to the
'collection colWinners. By adding the value as Key
'we ensure that there will be no duplicates
' - that is: Only one instance of each winning number.
For Each rCell In rInput
With rInput
'Generate a random Integer. The number
'will be between 1 and the number of cells
'in the table.
lVal = Int(.Count * Rnd() + 1)
'The value in the cell with the corresponding
'random number in the range rInput, is added to
'colWinners. If the number is already there, it
'will not be added.
colWinners.Add Int(.Item(lVal).Value), _
Str$(Int(.Item(lVal).Value))
If colWinners.Count = 6 Then Exit For
End With
Next
On Error GoTo ErrorHandle
'The winning numbers are now inserted on Sheet 2.
Set rCell = Worksheets(2).Range("A1")
rCell.Value = "Winning lots:"
With colWinners
For lVal = 1 To .Count
rCell.Offset(lVal, 0).Value = .Item(lVal)
Next
End With
'Activate the sheet with the winning lots:
Worksheets(2).Activate
BeforeExit:
Set rCell = Nothing
Set rInput = Nothing
Set colCheck = Nothing
Set colWinners = Nothing
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure LottoCheat."
Resume BeforeExit
End Sub
