RSS

Random numbers and drawing lots with Excel VBA

A reader asked me if I would make an example on how to generate random numbers with Excel VBA, and I did because it was funny.

Random numbers can be used for spot checking, encryption, drawing lots etc., and it is a science by itself.

With the worksheet function "= RAND()" you can get a random number in a cell, and in VBA you use the function "Rnd()".

Returning to the reader's request he wanted seven random and different "winner numbers" from a table. This implicates that if the same number occurs in the table more than once, the propability for drawing that number increases.

In other words: He wanted to cheat!

Below I show how to do that (the procedure LottoCheat). Afterwards I show, how VBA can make a table with unique random numbers (no duplicates), so you can have a fair draw.

The example also shows how you can define an interval for the random number (e.g. 1 - 1000).

Pseudorandom numbers

However before I proceed with the examples, I must say, that Excel doesn't generate true random numbers like e.g. throwing a dice - it generates socalled pseudorandom numbers.

VBA (and other programs) uses an algorithm that uses a "seed value" as start value. Programs will often use the computers clock to generate this seed value.

If you know the value, it is theoretically possible to calculate the "random" numbers, and that would be unfortunate if they are used for e.g. encryption or lotto!

The command "Randomize" forces VBA to reset the number generator so it gets a new seed value.

It is all pretty complicated, but at Wikipedia you can read more about pseudorandom numbers.

Drawing lots

Below is an example for drawing lots from a table. For the example to work there must be a table starting in cell A1 on the first worksheet. To test the macro, highlight it with the mouse, copy (CTRL+C) and paste (CTRL+V) into a VBA module.


Sub LottoCheat()
'Draws lots from values in a table finding 7 different winning 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 = 8 Then Exit For
Next

'If there are not 8 different values in the table, we exit.
If colCheck.Count < 8 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 = 7 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

Table with unique random numbers

The example below shows how to make a table with unique random numbers - that is: without duplicates.

If you use this procedure, you can make a fair draw with the procedure above (and then you should probably not call it "LottoCheat"!).

Again: You can highlight the code with the mouse, copy (CTRL+C) and paste (CTRL+V) into a VBA module.


Sub MakeUniqueTable()

'Makes a table with random and unique Integers.
'The trick to avoid duplicates is to add each number
'to a collection and at the same time use the number
'as Key. Keys in a collection must be unique, and
'if you try to add a duplicate key, it will
'trigger an error. This ensures that our table
'will have unique numbers.

'NOTE! With very large tables this can take a while, because
'the number generator will generate numbers that are already
'in the table, and then it takes extra time to finish.
'Usually the speed is so high that it doesn't matter,
'and you can reduce the probability for duplicates
'by increasing the interval for the random numbers.

Dim rTable As Range
Dim rCell As Range
Dim lMin As Long
Dim lMax As Long
Dim lVal As Long
Dim colValues As Collection

On Error GoTo ErrorHandle

'The table is defined as the range A1 to J30 on the first worksheet.
Set rTable = Worksheets(1).Range("A1", "J30")

'Define the interval (here 1 to 1000).
lMin = 1
lMax = 1000

'Check: The interval must be at least as
'big as the number of cells in the table.
If lMax - lMin < rTable.Count Then
   MsgBox "The interval is too small.", vbCritical
   GoTo BeforeExit
End If

'Reset the number generator so it gets a new seed value.
Randomize

Set colValues = New Collection

'The trick to getting unique values only is that we
'now set error handling to "Resume Next". Without
'doing that the program would crash if you tried to
'add an already existing key to the collection.
'Now the program just skips the duplicate and continues.

On Error Resume Next

'Now we start the loop that generates random numbers.
'The loop continues, until colValues has as many items
'as cells in the table, rTable.
Do Until colValues.Count = rTable.Count
   'lVal is set to a randow Integer in our defined interval.
   lVal = Int((lMax - lMin + 1) * Rnd() + lMin)

   'Add to colValues with the number as key.
   colValues.Add lVal, Str$(lVal)
Loop

On Error GoTo ErrorHandle

'Loop through colValues and write the values to the table.
With colValues
   For lVal = 1 To .Count
      rTable.Item(lVal).Value = .Item(lVal)
   Next
End With

BeforeExit:
Set rCell = Nothing
Set rTable = Nothing
Set colValues = Nothing

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure MakeUniqueTable."
Resume BeforeExit
End Sub

As a final note I'll add, that the function Rnd() happily returns numbers with decimals. That is why I have converted the numbers to Integers using the VBA function Int().

Related: