Generating a Random Number Table, where all of the numbers within the table are not used

[robreich]

I received some help on this Forum last October from Rick Rothstein creating a Random Number generator table, assuming 500 numbers (1 - 500). This Table is being used for a Reverse Raffle at a Charity Function in Ohio. To execute the macro, I am prompted to enter the first number in the Table, the last number in the Table, and how many numbers I want in each row of the Random Number Table. A question has come up as we approach our first use of the macro this coming October. What if all of the 500 tickets are not sold? They are being sold by multiple people that are members of the organization that is sponsoring the Charity Function. Everyone is given 10 tickets to sell. In a lot of cases, they sell only a portion of them and turn the unsold ones back into the Chairman. He then tries to use them as he gets more requests for tickets, but by the Evening of the fund raiser, there are always a number of tickets that have not been sold. Obviously, if the last ticket sold is less than 500, we simply enter that as the LAST NUMBER. However, is there a way to deal with the issue if tickets within the Table have not been sold, i.e. Tickets Number 275 thru 280 do not sell, 340 thru 345 do not sell, etc.? Right now, we are assuming that their are no unsold tickets in the Table of Numbers. One of the reasons of trying to address this is that every 10th ticket drawn wins a $25.00 Gift Card. If we simply put the unsold tickets up on the board and remove them as they are "drawn", then the "unsold tickets" mess up the Gift Cards.


I was thinking along the lines of building a Table Range that contains all of the SOLD Tickets only (leaving a blank cell where a ticket has not sold). Then, having the macro pull the random numbers from this Table Range. Not sure if that makes sense or it is doable, but if someone could help me with this, it would be greatly appreciated.

I am working in EXCEL 365 and my Operation System is Windows 10.

If someone needs additional information or has questions, please post them here. I will be checking the forum daily.

Thank you in advance for any help you can give me.

Bob Reichert

 

[Peter_SSs]

I hope that makes sense.

It makes absolutely no sense at all to me. If, say, two sets of draws have been made, drawing the next set from the remaining numbers & showing them in a couple of milliseconds time is no different at all to drawing that next set of numbers from the (identical) remaining numbers & showing them in ten seconds time or 3 days time. There is still exactly the same chance that any particular set of numbers will show up in the next draw, or the draw after that etc.

Having said that, if it will keep somebody happy, it can be done that way.
If Sheet2 starts empty, this will draw a set of numbers each time the code is run until all have been used. The next time it is run it will clear Sheet2 and start again with the full set of available numbers.

Sub DrawNumbers_v2()
  Dim d As Object
  Dim i As Long, r As Long, c As Long, Low As Long, High As Long, Cols As Long, Draw As Long
  Dim cell As Range
  
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Sheet1")
    Low = .Range("A2").Value
    High = .Range("B2").Value
    Cols = .Range("C2").Value
    For i = Low To High
      d(i) = 1
    Next i
    For r = 2 To .Range("D" & .Rows.Count).End(xlUp).Row
      For i = Split(.Cells(r, "D").Value, "-")(0) To Split(.Cells(r, "D").Value & "-" & .Cells(r, "D").Value, "-")(1)
        d.Remove i
      Next i
    Next r
  End With
  With Sheets("Sheet2")
    If Range("A1").Value <> "" Then
      If .UsedRange.SpecialCells(xlConstants, xlNumbers).Cells.Count = d.Count Then
        .UsedRange.ClearContents
      Else
        For Each cell In .UsedRange.SpecialCells(xlConstants, xlNumbers)
          d.Remove cell.Value
        Next cell
      End If
    End If
    r = IIf(Range("A1").Value = "", 1, .Range("A" & .Rows.Count).End(xlUp).Row + 1)
    If Cols > d.Count Then Cols = d.Count
    Randomize
    For i = 1 To Cols
      c = c + 1
      Draw = d.Keys()(Int(Rnd() * d.Count))
      .Cells(r, c).Value = Draw
      d.Remove Draw
    Next i
  End With
End Sub

 

[robreich]

I copied your macro into a BLANK EXCEL Workbook with Sheet1 and Sheet2 and it would not run. Tried putting a full column of numbers in Sheet2, Column A, and a partial column of numbers in Sheet2, Column B to represent the removal of unused numbers and that did not help.

 

[robreich]

I copied your Code into a BLANK EXCEL workbook with a Sheet1 and Sheet2 and then put a full column of numbers in Column A (1-200) and then a partial Column of numbers in Column B (1-200 with 25-50 removed). When I try to Run the Macro, it does not run.

 

[Peter_SSs]

Your original question was about selecting a variable number of numbers from a range of ticket numbers, some of which were not sold. My earlier suggestion used a worksheet to record that information - see columns A:D in post 3. My latest code uses that same layout (in Sheet1). Try that.

 

[robreich]

OK. I built your little Table on Sheet1, A:D and entered parameters. When I try to run the macro now, I get error message as follows: Runtime Error 1004. No Cells were found. When I run the DEBUG, the following line is highlighted in YELLOW: If .UsedRange.SpecialCells(xlConstants, xlNumbers).Cells.Count = d.Count Then

 

[robreich]

Peter,
I figured out what I was doing wrong. It is now working. Can you make a couple of changes? I noticed that when the last numbers are posted, if you don't realize that you are done and you execute the macro, all of the table is erased and it starts all over again. I need to have the Macro STOP when the last numbers are entered into the Table. Starting all over again we lose all of the information in the event that there is any question about the drawing. Also, can you make the table scroll up as a row is added, i.e. it would be nice if the top row on the screen is always the row just drawn and the previous rows are scrolled up off of the screen. Lastly, is there a way to ERASE everything on Sheet2 automatically before running the macro? It may have to be a separate macro that gets executed before running the DrawNumbers Macro.

I have tested it on a 100 number Table and a 600 number Table and everything else is just what I wanted. Thanks for your help.

Bob

 

[Rick Rothstein]

Here is my code modified to do all I think I have understood you want. Note the lone Public declaration at the top... it must remain at the top of the module you place the code in even if you put the rest of the code underneath other code you might have in the module (probably best to simply put all of the code below in its own code module). As before, you would run the ListTicketNumbers subroutine to establish a list of possible numbers on Sheet2, then you would clear the numbers from that list for any unsold tickets. Running ListTicketNumbers subroutine clears both Sheet1 and Sheet2 of any existing information. If you accidentally run it before you are ready to list new numbers, simply click Cancel on the InputBox asking you for the beginning or ending ticket numbers. Next, just run the RandomDrawTableMaker subroutine to generate a new row of randomly drawn ticket numbers. Note that you will only be asked for how many ticket numbers to list the first time a table is to be generated, the rest of the numbers till the last listed row will assume the same number per row that you specified for the first row of random ticket numbers. Here is the code...

[table="width: 500"]
[tr]
	[td]Public TicketNumbersPerRow As Variant

Sub ListTicketNumbers()
  Dim L As Long, H As Long
  
  ' Get upper and lower limits for the ticket numbers
  On Error GoTo NoNumbers
  L = InputBox("Enter the low ticket number:")
  H = InputBox("Enter the high ticket number:")
  On Error GoTo 0
  
  ' Print the ticket numbers out to Sheet2, Column A starting on Row 1
  Sheets("Sheet2").Cells.Clear
  Sheets("Sheet2").Range("A1").Resize(H - L + 1) = Evaluate("ROW(" & L & ":" & H & ")")
  With Sheets("Sheet1")
    .Cells.Clear
    .Activate
  End With
  ActiveWindow.ScrollRow = 1
  TicketNumbersPerRow = ""
  
NoNumbers:
End Sub

Sub RandomDrawTableMaker()
  Dim Rw As Long, X As Long, LastRow As Long, Cnt As Long, OldUB As Long
  Dim RandomIndex As Long, Tmp As Long, Nums As Variant
  
  ' Make sure the number will always be random each time macro is run
  Randomize
  
  ' Get information to build grid
  If TicketNumbersPerRow = "" Then
    On Error GoTo NoNumbers
    TicketNumbersPerRow = InputBox("Enter the number of tickets per row:")
    On Error GoTo 0
  End If
  
  ' Read the sold ticket numbers into a one-dimension array
  With Sheets("Sheet2")
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    .Columns("B").Clear
    .Range("A1:A" & LastRow).Copy .Range("B1")
    On Error Resume Next
    .Columns("B").SpecialCells(xlBlanks).Delete xlShiftUp
    On Error GoTo 0
    LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
    Nums = Application.Transpose(.Range("B1:B" & LastRow))
  End With
  
  ' Randomize the ordered one-dimensional array of all the numbers
  If TypeName(Nums) = "Variant()" Then
    For Cnt = UBound(Nums) To 1 Step -1
      RandomIndex = Int(Cnt * Rnd + 1)
      Tmp = Nums(RandomIndex)
      Nums(RandomIndex) = Nums(Cnt)
      Nums(Cnt) = Tmp
    Next
  Else
    If Nums Then
      Nums = Split(Nums)
    Else
      Nums = Split("***Done***")
    End If
  End If
  
  ' Distribute the random array of numbers into the grid one row at a time
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    OldUB = UBound(Nums)
    ReDim Preserve Nums(1 To TicketNumbersPerRow + UBound(Nums))
    Rw = .Cells(Rows.Count, "A").End(xlUp).Row
    If Not (Rw = 1 And Range("A1") = "") Then Rw = Rw + 1
    .Cells(Rw, "A").Resize(, TicketNumbersPerRow) = Application.Index(Nums, 1, 0)
    ActiveWindow.ScrollRow = Rw
    For X = 1 To TicketNumbersPerRow
      Sheets("Sheet2").Columns("A").Replace Nums(X), "", xlWhole, , False, , False, False
    Next
  End With
  Application.ScreenUpdating = True
  
NoNumbers:
End Sub[/td]
[/tr]
[/table]

 

[robreich]

Rick,

I opened up my most recent template, deleted all of the macros, and then copied your code into that Template and saved it under a new name. It seems to run ok, but there are a couple of quirks that I would like you to look at.

I have my Sheet1 formatted in Arial Font Size 20 so I don't have to keep squinting at the screen. For some reason, every time I run the first macro (ListNumbers), as soon as I enter the High Number, Sheet1 reverts back to the default font and font size. I also have the numbers formatted to Custom 000 so that all number have three digits - 001, 002, 010, etc. This format also gets reverted back to General. Can this be fixed? I know it didn't do this with your previous Code.

I ran a test of a List of 250 numbers. I went in and deleted 5 groups of 10 numbers, leaving me with 200 numbers to put into 20 rows of 10 random numbers. However, I noticed that after the Column B list was created, there were a bunch of other numbers missing from Column A (numbers deleted that I did not delete). I probably would not have noticed this if I had not limited my deletions to groups of 10 numbers. Column B had 200 numbers in it, so I don't know what was going on there. I ran several different sizes of lists and it happened every time. This issue concerns me because if we were deleting a bunch of single and/or small groups of numbers, we would not easily identify which numbers we deleted if we had to go back and double check them.

I noticed that when the second macro is DONE, all of the data on Sheet2 is erased. I would rather have this remain on the Sheet and be deleted at the beginning of the first macro only. If there is any problem with the drawing, we can't go back and check the data because it is gone.

I hope these are easy fixes.

Thanks for your help.

Bob

 

[Rick Rothstein]

I think the following modified code addresses all of the concerns you raised in Message #18 (if not, please let me know)...

[table="width: 500"]
[tr]
	[td]Public TicketNumbersPerRow As Variant

Sub ListTicketNumbers()
  Dim L As String, H As String
  
  ' Get upper and lower limits for the ticket numbers
  On Error GoTo NoNumbers
  L = InputBox("Enter the low ticket number:")
  H = InputBox("Enter the high ticket number:")
  On Error GoTo 0
  
  ' Print the ticket numbers out to Sheet2, Column A starting on Row 1
  Sheets("Sheet2").Cells.Clear
  With Sheets("Sheet2").Range("A1").Resize(H - L + 1)
    .NumberFormat = "@"
    .Value = Evaluate("IF({1},TEXT(ROW(" & L & ":" & H & "),REPT(0," & Len(L) & ")))")
  End With
  Sheets("Sheet1").Cells.ClearContents
  ActiveWindow.ScrollRow = 1
  TicketNumbersPerRow = ""
  
NoNumbers:
End Sub

Sub RandomDrawTableMaker()
  Dim Rw As Long, X As Long, LastRow As Long, Cnt As Long, OldUB As Long
  Dim RandomIndex As Long, Tmp As String, Nums As Variant
  
  ' Make sure the number will always be random each time macro is run
  Randomize
  
  ' Get information to build grid
  If TicketNumbersPerRow = "" Then
    On Error GoTo NoNumbers
    TicketNumbersPerRow = InputBox("Enter the number of tickets per row:")
    On Error GoTo 0
    With Sheets("Sheet2")
      LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
      .Columns("B").Clear
      .Range("A1:A" & LastRow).Copy
      .Range("B1").PasteSpecial (xlPasteValuesAndNumberFormats)
    End With
  End If
  
  ' Read the sold ticket numbers into a one-dimension array
  With Sheets("Sheet2")
    LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
    On Error Resume Next
    .Columns("B").SpecialCells(xlBlanks).Delete xlShiftUp
    On Error GoTo 0
    LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
    Nums = Application.Transpose(.Range("B1:B" & LastRow))
  End With
  
  ' Randomize the ordered one-dimensional array of all the numbers
  If TypeName(Nums) = "Variant()" Then
    For Cnt = UBound(Nums) To 1 Step -1
      RandomIndex = Int(Cnt * Rnd + 1)
      Tmp = Nums(RandomIndex)
      Nums(RandomIndex) = Nums(Cnt)
      Nums(Cnt) = Tmp
    Next
  Else
    If Nums Then
      Nums = Split(Nums)
    Else
      Nums = Split("***Done***")
    End If
  End If
  
  ' Distribute the random array of numbers into the grid one row at a time
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    OldUB = UBound(Nums)
    ReDim Preserve Nums(1 To TicketNumbersPerRow + UBound(Nums))
    Rw = .Cells(Rows.Count, "A").End(xlUp).Row
    If Not (Rw = 1 And Range("A1") = "") Then Rw = Rw + 1
    .Cells(Rw, "A").Resize(, TicketNumbersPerRow).NumberFormat = Sheets("Sheet2").Range("B1").NumberFormat
    .Cells(Rw, "A").Resize(, TicketNumbersPerRow) = Application.Index(Nums, 1, 0)
    ActiveWindow.ScrollRow = Rw
    For X = 1 To TicketNumbersPerRow
      Sheets("Sheet2").Columns("B").Replace Nums(X), "", xlWhole, , False, , False, False
    Next
  End With
  Application.ScreenUpdating = True
  
NoNumbers:
End Sub[/td]
[/tr]
[/table]

 

[Peter_SSs]

I noticed that when the last numbers are posted, if you don't realize that you are done and you execute the macro, all of the table is erased and it starts all over again. I need to have the Macro STOP when the last numbers are entered into the Table. Starting all over again we lose all of the information in the event that there is any question about the drawing. Also, can you make the table scroll up as a row is added, i.e. it would be nice if the top row on the screen is always the row just drawn and the previous rows are scrolled up off of the screen. Lastly, is there a way to ERASE everything on Sheet2 automatically before running the macro? It may have to be a separate macro that gets executed before running the DrawNumbers Macro.

Some of this seems contradictory to me. For example, you want everything cleared before we run the macro - but the macro is run each time a draw is made so that would be clearing it every time, destroying the history you wanted to keep.

See if this is any use. Add an extra column in Sheet1 as shown. Enter Yes in E2 if you know you want to clear Sheet2 and start fresh.

Book1
	A	B	C	D	E
1	Low	High	#s Per Row	Exclude	Start Again
2	1	500	10	5	Yes
3				19
4				25-28
5				101-450
6				500
Sheet1

The code will double-check on that with you when the code is run but it will also prompt a choice if all numbers have been drawn and you run the code again without re-entering that yes (the code clears the yes if you confirm clearing Sheet2).

Sub DrawNumbers_v3()
  Dim d As Object
  Dim i As Long, r As Long, c As Long, Low As Long, High As Long, Cols As Long, Draw As Long
  Dim cell As Range, rStartOver As Range
  Dim Resp As VbMsgBoxResult
  
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Sheet1")
    Low = .Range("A2").Value
    High = .Range("B2").Value
    Cols = .Range("C2").Value
    Set rStartOver = .Range("E2")
    For i = Low To High
      d(i) = 1
    Next i
    For r = 2 To .Range("D" & .Rows.Count).End(xlUp).Row
      For i = Split(.Cells(r, "D").Value, "-")(0) To Split(.Cells(r, "D").Value & "-" & .Cells(r, "D").Value, "-")(1)
        d.Remove i
      Next i
    Next r
  End With
  With Sheets("Sheet2")
    .Activate
    If .Range("A1").Value <> "" Then
      If .UsedRange.SpecialCells(xlConstants, xlNumbers).Cells.Count = d.Count Or LCase(rStartOver.Value) = "yes" Then
        Resp = MsgBox(Prompt:="Do you want to clear all draws and start again?", Buttons:=vbYesNo)
        If Resp = vbYes Then
          .UsedRange.ClearContents
          rStartOver.ClearContents
        Else
          MsgBox "OK, process aborted"
          Exit Sub
        End If
      Else
        For Each cell In .UsedRange.SpecialCells(xlConstants, xlNumbers)
          d.Remove cell.Value
        Next cell
      End If
    End If
    r = IIf(Range("A1").Value = "", 1, .Range("A" & .Rows.Count).End(xlUp).Row + 1)
    If Cols > d.Count Then Cols = d.Count
    Randomize
    For i = 1 To Cols
      c = c + 1
      Draw = d.Keys()(Int(Rnd() * d.Count))
      .Cells(r, c).Value = Draw
      d.Remove Draw
    Next i
    ActiveWindow.ScrollRow = r
  End With
End Sub