Excel VBA to get Random Integer Values without repetitions - excel

Question

Write a subroutine in VBA to generate a winning lotto ticket consisting of 6 integer numbers randomly drawn from 1 to 40.
In order to have a small simulation animation, range("A1:E8") should contain the numbers 1 to 40 and the subroutine should then cycle through these numbers using a colored cell and then momentarily pause 2 seconds on a selected winning number. The list of winning numbers drawn should then be printed in the range("G2:G7"). In case a number drawn has already been drawn previously in the list, then a new number should be redrawn.
I have only been able to do as follows.
Option Explicit
Sub test1()
Sheet1.Cells.Clear
Dim i As Integer
For i = 1 To 40
Cells(i, 1) = i
Next
End Sub
'-----------------------------
Option Explicit
Option Base 1
Function arraydemo(r As Range)
Dim cell As Range, i As Integer, x(40, 1) As Double
i = 1
For Each cell In r
x(i, 1) = cell.Value
i = i + 1
Next cell
arraydemo = x
End Function
Sub test3()
Dim x() As String
chose = Int(Rnd * UBound(x))
End Sub
I got stuck elsewhere, the sub test3(), does not seem appropriate here. I need some suggestions. Also, I appologise for my poor formatting, I am new to this.

Answer 1

Populating your range like this:
range("A1:E8") should contain the numbers 1 to 40
Sheet1.Cells.Clear
Dim i As Integer
Dim rng as Range
Set rng = Range("A1:E8")
For i = 1 To 40
rng
Next
generate a winning lotto ticket consisting of 6 integer numbers randomly drawn from 1 to 40
Using a dictionary object to keep track of which items have been picked (and prevent duplicate) in a While loop (until there are 6 numbers chosen):
Dim picked as Object
Set picked = CreateObject("Scripting.Dictionary")
'Select six random numbers:
i = 1
While picked.Count < 6
num = Application.WorksheetFunction.RandBetween(1, 40)
If Not picked.Exists(num) Then
picked.Add num, i
i = i + 1
End If
Wend
Using the Application.Wait method to do the "pause", you can set up a procedure like so:
'Now, show those numbers on the sheet, highlighting each cell for 2 seconds
For Each val In picked.Keys()
rng.Cells(picked(val)).Interior.ColorIndex = 39 'Modify as needed
Application.Wait Now + TimeValue("00:00:02")
rng.Cells(picked(val)).Interior.ColorIndex = xlNone
Next
The list of winning numbers drawn should then be printed in the range("G2:G7").
Print the keys from the picked dictionary:
Range("G2:G7").Value = Application.Transpose(picked.Keys())
Putting it all together:
Sub Lotto()
Dim i As Integer, num As Integer
Dim rng As Range
Dim picked As Object 'Scripting.Dictionary
Dim val As Variant
'Populate the sheet with values 1:40 in range A1:E8
Set rng = Range("A1:E8")
For i = 1 To 40
rng.Cells(i) = i
Next
'Store which numbers have been already chosen
Set picked = CreateObject("Scripting.Dictionary")
'Select six random numbers:
i = 1
While picked.Count < 6
num = Application.WorksheetFunction.RandBetween(1, 40)
If Not picked.Exists(num) Then
picked.Add num, i
i = i + 1
End If
Wend
'Now, show those numbers on the sheet, highlighting each cell for 2 seconds
For Each val In picked.Keys()
rng.Cells(val).Interior.ColorIndex = 39 'Modify as needed
Application.Wait Now + TimeValue("00:00:02")
rng.Cells(val).Interior.ColorIndex = xlNone
Next
'Display the winning series of numbers in G2:G7
Range("G2:G7").Value = Application.Transpose(picked.Keys())
End Sub
NOTE This absolutely will not work on Excel for Mac, you would need to use a Collection instead of a Dictionary, as the Scripting.Runtime library is not available on Mac OS.

Answer 2

In addition to the excellent answer given by member David Zemens, following is the universal function written in "pure" Excel VBA, which does not contain any Excel Worksheet Functions, neither Dictionary Object (re: CreateObject("Scripting.Dictionary").
Option Explicit
'get N random integer numbers in the range from LB to UB, NO repetition
'general formula: Int ((UpperBound - LowerBound + 1) * Rnd + LowerBound)
Function RandomNumbers(LB As Integer, UB As Integer, N As Integer) As Variant
Dim I As Integer
Dim arrRandom() As Integer
Dim colRandom As New Collection
Dim colItem As Variant
Dim tempInt As Integer
Dim tempExists As Boolean
'check that ArraySize is less that the range of the integers
If (UB - LB + 1 >= N) Then
While colRandom.Count < N
Randomize
' get random number in interval
tempInt = Int((UB - LB + 1) * Rnd + LB)
'check if number exists in collection
tempExists = False
For Each colItem In colRandom
If (tempInt = colItem) Then
tempExists = True
Exit For
End If
Next colItem
' add to collection if not exists
If Not tempExists Then
colRandom.Add tempInt
End If
Wend
'convert collection to array
ReDim arrRandom(N - 1)
For I = 0 To N - 1
arrRandom(I) = colRandom(I + 1)
Next I
'return array of random numbers
RandomNumbers = arrRandom
Else
RandomNumbers = Nothing
End If
End Function
'get 5 Random numbers in the ranger 1...10 and populate Worksheet
Sub GetRandomArray()
Dim arr() As Integer
'get array of 5 Random numbers in the ranger 1...10
arr = RandomNumbers(1, 10, 5)
'populate Worksheet Range with 5 random numbers from array
If (IsArray(arr)) Then
Range("A1:A5").Value = Application.Transpose(arr)
End If
End Sub
The function
Function RandomNumbers(LB As Integer, UB As Integer, N As Integer)
returns array of N random numbers in the range LB...UB inclusively without repetition.
Sample Sub GetRandomArray() demonstrates how to get 5 random numbers in the range 1...10 and populate the Worksheet Range: it could be customized for any particular requirements (e.g. 8 from 1...40 in PO requirements).
APPENDIX A (Courtesy of David Ziemens)
Alternatively, you can do similar without relying on Collection object at all. Build a delimited string, and then use the Split function to cast the string to an array, and return that to the calling procedure.
This actually returns the numbers as String, but that shouldn't matter for this particular use-case, and if it does, can easily be modified.
Option Explicit
Sub foo()
Dim arr As Variant
arr = RandomNumbersNoCollection(1, 40, 6)
End Sub
'get N random integer numbers in the range from LB to UB, NO repetition
'general formula: Int ((UpperBound - LowerBound + 1) * Rnd + LowerBound)
Function RandomNumbersNoCollection(LB As Integer, UB As Integer, N As Integer)
Dim I As Integer
Dim numbers As String ' delimited string
Dim tempInt As Integer
Const dlmt As String = "|"
'check that ArraySize is less that the range of the integers
If (UB - LB + 1 >= N) Then
' get random number in interval
Do
Randomize
tempInt = Int((UB - LB + 1) * Rnd + LB)
If Len(numbers) = 0 Then
numbers = tempInt & dlmt
ElseIf InStr(1, numbers, tempInt & dlmt) = 0 Then
numbers = numbers & tempInt & dlmt
End If
Loop Until UBound(Split(numbers, dlmt)) = 6
numbers = Left(numbers, Len(numbers) - 1)
End If
RandomNumbersNoCollection = Split(numbers, dlmt)
End Function