Better Random, No Repeat, In Order with Excel Macro

Question

I have been working on this project for a while, and have had various help throughout (haven't touched code in a number of years)

I'm creating a lottery ticket generator, and I'm finally almost finished, but my random needs some work, and I'd like to display the numbers in ascending order with separated by hyphen, as the following example without the parenthesis: "12-16-24"

Currently my code puts a different random number (1-24) across three columns in a row and repeats until the loop is complete. The code should minimize the columns to 1 "lottery" column instead of three.

Any idea, how I could go about doing this? My current code to follow:

Sub New_Entry()
  Dim strPlayer As String, strTick As Integer, i As Integer, j As Integer
  strPlayer = InputBox("Input Player Name")
  strTick = InputBox("How many tickets?")
  i = Cells(Rows.Count, 1).End(xlUp).Row + 1
  For i = i To i + strTick - 1
    Cells(i, 1).Value = strPlayer
    For j = 2 To 4
      Cells(i, j).Value = Int((24 - 1 + 1) * Rnd + 1)
    Next j
  Next i
End Sub

John Coleman · Answer 1 · 2016-03-05T20:26:26.503

1

The following might help you:

Function LotteryTicket() As String
    Dim i As Long
    Dim nums(1 To 3) As Integer
    Dim A(1 To 3) As Variant

    With Application.WorksheetFunction
        Do While True
            For i = 1 To 3
                nums(i) = .RandBetween(1, 24)
            Next i
            For i = 1 To 3
                A(i) = .Small(nums, i)
            Next i
            If A(1) <> A(2) And A(2) <> A(3) Then
                LotteryTicket = Join(A, "-")
                Exit Function
            End If
        Loop
    End With

End Function

It uses a simple hit-and-miss approach to get distinct numbers. The probability that 3 randomly chosen numbers in 1-24 are distinct is P(24,3)/24^3 = 87.8% so the expected number of runs through the outer loop is less than 2.

Tested like this:

Sub test()
    Dim i As Long
    For i = 1 To 10
        Cells(I,1).Value = LotteryTicket()
    Next i
End Sub

After running this the output looks like (assuming that the cells are formatted as text so Excel doesn't interpret things as dates):

1-7-10
1-17-23
8-14-15
8-12-24
2-14-17
4-7-14
5-6-23
16-20-21
4-10-24
6-11-15

edited Mar 05 '16 at 20:26

answered Mar 05 '16 at 19:21

John Coleman

51,337
7
54
119

Thank you! How can I make sure not to get repeats like that though? 12-23-23 and 11-11-12 for instances are a no-go :( – Jacob Hooper Mar 05 '16 at 19:24
Very elegant code John, I like how you sorted the array. Are there any drawbacks vs the Bublesort method? – Cornel Mar 05 '16 at 19:36
@JacobHooper I modified it to satisfy that requirement – John Coleman Mar 05 '16 at 20:26
@Cornel With a small handful of elements there is no reason to worry too much about how things are sorted. – John Coleman Mar 05 '16 at 20:29

score 0 · Accepted Answer · answered Mar 05 '16 at 19:31

If you do not want repeats just test if the numbers are already in the array, if true, then calculate a new random number (this code is written for 6 winning numbers):

Sub New_Entry()
Dim strPlayer As String, strTick As Integer, i As Integer, j As Integer
Dim win_tkt As Variant
Dim number_to_find As Integer
 strPlayer = InputBox("Input Player Name")
 strTick = InputBox("How many tickets?")

  ReDim win_tkt(5) 'how many numbers are extracted -1
  i = Cells(Rows.Count, 1).End(xlUp).Row + 1
  For i = i To i + strTick - 1
    Cells(i, 1).Value = strPlayer

    win_tkt(0) = Int((24 - 1 + 1) * Rnd + 1)
    For j = 2 To 6 'from 2nd winning number to last winning number
      number_to_find = Int((24 - 1 + 1) * Rnd + 1)
      Do While IsInArray(number_to_find, win_tkt) = True
            number_to_find = Int((24 - 1 + 1) * Rnd + 1)
       Loop
       win_tkt(j - 1) = number_to_find

    Next j
      Call sort_array(win_tkt)
    Cells(i, 2).Value = Join(win_tkt, "-")
  Next i
End Sub

Function IsInArray(find_number As Integer, arr As Variant) As Boolean
    IsInArray = (UBound(Filter(arr, find_number)) > -1)
End Function

Sub sort_array(arr As Variant)
    Dim strTemp As String
    Dim i As Long
    Dim j As Long
    Dim lngMin As Long
    Dim lngMax As Long
    lngMin = LBound(arr)
    lngMax = UBound(arr)
    For i = lngMin To lngMax - 1
      For j = i + 1 To lngMax
        If arr(i) > arr(j) Then
          strTemp = arr(i)
          arr(i) = arr(j)
          arr(j) = strTemp
        End If
      Next j
    Next i
End Sub

This works wonderfully as written, but when I try to reduce the win_tck to 2 (so that 3 numbers are extracted, am I following the code right so far?) I get a bug alert and the macro stops, point to "win_tkt(j - 1) = number_to_find" — Jacob Hooper, Mar 05 '16 at 19:56

Better Random, No Repeat, In Order with Excel Macro

2 Answers2