UK Bingo cards

craigey1 · Apr 6, 2020

Apologies for asking for so much help on my very first post here.

I've been searching all over for a solution to be able to produce a UK style bingo card within Excel using formulas or VBA, but so far have only found code that's capable of producing singular games rather than a set of 6. I've searched here & seen that the question has been asked before, but so far no-one seems to have been able to come up with a solution. I thought I could look at randbetween() to generate the necessary numbers for each column, but couldn't see how to then comply the required game layout rules. I really don't know where to start with this. I'd normally try & then ask for help when stuck, so here I am!

The UK bingo games use numbers 1 to 90 (including 90) with the numbers split across 6 games of 3 rows by 9 columns. The number 1 to 9 would appear in the first column, 10 to 19 in column 2, 20 to 29 column 3 & so on until the 9th column which also includes the number 90. All numbers would only appear once across all 6 of the games & each box has 5 blanks across each row & can have 0, 1 or 2 blanks per column.
In summary:
1. A bingo 'card' is a set of 6 individual 3 x 9 grids, stacked vertically, which contain the numbers 1-90
2. The numbers 1 - 9 (9 numbers) are in the first column and 80-90 (11 numbers) in the 9th, the intervening columns (2-8) contain 10 numbers each.
3. An individual box has 15 numbers, 5 per row and between 0 and 2 per column

I'd appreciate any help with this as was hoping to generate cards for friends / family during the lockdown.

thanks in advance

tezza · Dec 14, 2022

lrobbo314 said:

Right. I got so hung up on working on the new version and totally forgot about that 5 numbers per row deal.

Back to the old code with an update to sort.

UK BINGO

A

B

C

D

E

F

G

H

I

J

K

L

1

27

31

41

74

5

4

2

28

39

45

57

61

5

4

3

6

15

66

77

81

5

4

3

16

20

53

87

5

4

5

7

30

65

75

88

5

4

6

18

37

43

59

68

5

4

7

11

36

50

60

76

5

4

8

12

21

44

67

83

5

4

9

8

23

38

54

85

5

4

10

22

40

52

62

72

5

4

11

4

26

49

56

84

5

4

12

5

19

35

73

89

5

4

13

25

47

70

82

5

4

14

29

33

55

64

86

5

4

15

9

14

48

58

78

5

4

16

2

32

63

71

80

5

4

17

10

34

42

69

90

5

4

18

17

24

46

51

79

5

4

19

20

21

22

23

24

2

11

21

31

41

51

61

71

81

25

3

12

22

32

42

52

62

72

82

26

4

13

23

33

43

53

63

73

83

27

5

14

24

34

44

54

64

74

84

28

6

15

25

35

45

55

65

75

85

29

7

16

26

36

46

56

66

76

86

30

8

17

27

37

47

57

67

77

87

31

9

18

28

38

48

58

68

78

88

32

19

29

39

49

59

69

79

89

33

90

Sheet1

Cell Formulas
Range	Formula
K1:K18	K1	=COUNTA(A1:I1)
L1:L18	L1	=COUNTBLANK(A1:I1)
A20:I20	A20	=COUNTA(A1:A18)
A21:I21	A21	=COUNTBLANK(A1:A18)
A23:A31,I23:I33,B23:H32	A23	=SORT(FILTER(A1:A18,A1:A18<>""))
Dynamic array formulas.

VBA Code:

Sub Main()
Dim Result(1 To 162) As Variant
Dim Output(1 To 18, 1 To 9) As Variant
Dim AR(1 To 90) As Integer:     fillNums AR
Dim Patterns As Object:         setPatterns Patterns
Dim Six As Object:              setSix Six
Dim Grid As Object:             setGrid Grid
Dim Queue As Object

Shuffle AR
fillQueue Queue, AR
fillArray Result, Queue, Patterns, Six, Grid
fillOutput Result, Output
Range("A1").Resize(UBound(Output, 1), UBound(Output, 2)).Value2 = Output
End Sub

Sub setGrid(ByRef Grid As Object)
Set Grid = CreateObject("System.Collections.ArrayList")
Dim lo As Object, hi As Object, tmp As Object

For i = 0 To 5
    Set tmp = CreateObject("System.Collections.ArrayList")
    Set lo = CreateObject("System.Collections.ArrayList")
    Set hi = CreateObject("System.Collections.ArrayList")
    Select Case i
        Case 0
            lo.Add 2
            lo.Add 2
            lo.Add 1
            hi.Add 3
            hi.Add 3
            hi.Add 3
            hi.Add 5
            hi.Add 5
            hi.Add 4
        Case 1
            lo.Add 2
            lo.Add 1
            lo.Add 0
            hi.Add 5
            hi.Add 4
            hi.Add 3
            hi.Add 4
            hi.Add 3
            hi.Add 5
        Case 2
            lo.Add 0
            lo.Add 1
            lo.Add 2
            hi.Add 3
            hi.Add 5
            hi.Add 3
            hi.Add 4
            hi.Add 5
            hi.Add 4
        Case 3
            lo.Add 2
            lo.Add 2
            lo.Add 0
            hi.Add 4
            hi.Add 3
            hi.Add 4
            hi.Add 5
            hi.Add 3
            hi.Add 3
        Case 4
            lo.Add 1
            lo.Add 1
            lo.Add 2
            hi.Add 3
            hi.Add 3
            hi.Add 4
            hi.Add 5
            hi.Add 5
            hi.Add 5
        Case 5
            lo.Add 0
            lo.Add 2
            lo.Add 2
            hi.Add 4
            hi.Add 4
            hi.Add 5
            hi.Add 3
            hi.Add 3
            hi.Add 3
    End Select
tmp.Add lo
tmp.Add hi
Grid.Add tmp
Next i

End Sub

Sub setSix(ByRef Six As Object)
Set Six = CreateObject("System.Collections.ArrayList")

Six.Add Array(1, 0, 0)
Six.Add Array(0, 1, 0)
Six.Add Array(0, 0, 1)
Six.Add Array(1, 1, 0)
Six.Add Array(0, 1, 1)
Six.Add Array(1, 0, 1)
End Sub

Sub setPatterns(ByRef Patterns As Object)
Set Patterns = CreateObject("System.Collections.ArrayList")

Patterns.Add Array(2, 2, 1, 2, 1, 1)
Patterns.Add Array(1, 2, 2, 1, 2, 2)
Patterns.Add Array(2, 1, 2, 2, 2, 1)
Patterns.Add Array(2, 2, 2, 1, 1, 2)
Patterns.Add Array(2, 1, 1, 2, 2, 2)
Patterns.Add Array(1, 2, 2, 2, 2, 1)
Patterns.Add Array(2, 2, 2, 1, 1, 2)
Patterns.Add Array(2, 1, 1, 2, 2, 2)
Patterns.Add Array(1, 2, 2, 2, 2, 2)

End Sub

Function getRnd(hi As Variant, lo As Variant) As Integer
getRnd = Int(((hi + 1) - lo) * Rnd() + lo)
End Function

Sub fillQueue(ByRef Queue As Object, ByRef AR() As Integer)
Set Queue = CreateObject("System.Collections.Queue")
For i = 1 To UBound(AR)
    Queue.enqueue AR(i)
Next i
End Sub

Sub fillNums(ByRef AR() As Integer)
For i = 1 To 90: AR(i) = i: Next i
End Sub

Sub Shuffle(ByRef AR() As Integer)
Randomize
Dim Group As Integer, swap As Integer, tmp As Integer, gs As Integer

gs = 9

For i = 1 To UBound(AR) - 1
    If i = 10 Then gs = gs + 1
    If i < 10 Then
        Group = Int((i - 1) / gs) * gs
        swap = getRnd(Group + gs, Group + 1)
    ElseIf i < UBound(AR) - 10 Then
        Group = Int((i) / gs) * gs
        swap = getRnd(Group, Group + 10)
    Else
        Group = Int((i) / gs) * gs
        swap = getRnd(Group, Group + 11)
    End If
 
    tmp = AR(i)
    AR(i) = AR(swap)
    AR(swap) = tmp
Next i
End Sub

Sub fillArray(ByRef Result() As Variant, Queue As Object, Patterns As Object, Six As Object, Grid As Object)
Dim RN As Integer: RN = 0
Dim RP As Integer: RP = 0
Dim Pos As Integer: Pos = 1
Dim tmp As Variant
Dim Pat As Variant
Dim SA(0 To 2) As Variant
For i = 1 To 9
    tmp = Patterns(i - 1)
    For j = 0 To UBound(tmp)
 
        If tmp(j) = 1 Then
            RP = getRnd(Grid(j)(0).Count - 1, 0)
            Pat = Six(Grid(j)(0)(RP))
            Grid(j)(0).removeAt RP
        Else
            RP = getRnd(Grid(j)(1).Count - 1, 0)
            Pat = Six(Grid(j)(1)(RP))
            Grid(j)(1).removeAt RP
        End If
     
        For k = LBound(Pat) To UBound(Pat)
            If Pat(k) = 1 Then SA(k) = Queue.Dequeue()
        Next k
     
        sortSA SA
     
        For x = 0 To 2
            If SA(x) > 0 Then Result(Pos) = SA(x)
            Pos = Pos + 1
        Next x
     
        Erase SA
    Next j
Next i
End Sub

Sub sortSA(SA As Variant)
Dim tmp As Integer

For i = 0 To 2
    For j = i To 2
        If SA(i) > SA(j) And Not IsEmpty(SA(i)) And Not IsEmpty(SA(j)) Then
            tmp = SA(i)
            SA(i) = SA(j)
            SA(j) = tmp
        End If
    Next j
Next i
End Sub

Sub ShuffleOnesTwos(ByRef Pat As Variant)
Dim Pos As Integer, tmp As Integer

For i = LBound(Pat) To UBound(Pat)
    Pos = getRnd(UBound(Pat), 0)
    tmp = Pat(i)
    Pat(i) = Pat(Pos)
    Pat(Pos) = tmp
Next i
End Sub

Sub fillOutput(ByRef Result() As Variant, ByRef Output As Variant)
Dim Col As Integer: Col = 1
Dim Pos As Integer: Pos = 1
For i = LBound(Result) To UBound(Result)
    Output(Pos, Col) = Result(i)
    Pos = Pos + 1
    If i Mod 18 = 0 Then
        Col = Col + 1
        Pos = 1
    End If
Next i
End Sub

Working like a dream, thank you

My wife runs a deaf club and they really enjoy bingo nights. I will use this to create books and run the number generator that I've got up and running with other fine members here.

Plus I'm working on a digital version that also keeps track of the number generated.

You're input has been invaluable.

lrobbo314 · Dec 15, 2022

Man, did I go down the rabbit whole on this one. Combinations, permutations, a lot of banging my head.

Anyway, I wasn't happy with the latest version. You'll notice that you get the same sort of patterns in each column.

For example, in the first column, you'll always get 2 numbers in the first house, 2 in the second, 1 in the third, 2 in 4th, 1 in 5th, and 1 in 6th.

I wanted to add more randomness to the number of numbers you'll get. I found 10 unique sequences of numbers that will always result in 5 numbers per row for a given card. You can obviously swap any pattern with the card and it won't change the 5 per row requisite.

Then it was just a matter of shuffling those around until you got all the column totals correct.

Anyway, don't want to get ahead of myself because these things always seem to come back with some issues, but I think this is the ultimate version.

I'd love to hear what y'all think.

VBA Code:

Sub Main()
TurnOff
Dim Key(1 To 6, 1 To 9) As Integer:     setSix Key
Dim Board(1 To 18, 1 To 9) As Variant:  FillBoard Board, Key
Dim Totals(1 To 9) As Integer:          SumCols Board, Totals
Dim Answer(1 To 9) As Integer:          FillAnswer Answer
Dim AR(1 To 90) As Integer:             fillNums AR: Shuffle AR
Dim QUE As Object:                      fillQueue QUE, AR

Do Until CheckTotal(Totals, Answer)
    swap Answer, Totals, Key, Board
    DoEvents
Loop

AddNumbers Board, QUE
Range("A1:I18").Value = Board
TurnOn
End Sub

Sub TurnOff()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
End Sub

Sub TurnOn()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub AddNumbers(Board As Variant, QUE As Object)
Dim tmp As Variant

For i = 1 To 9
    For j = 1 To 18 Step 3
        tmp = Application.Index(Board, Array(j, j + 1, j + 2), i)
        For t = 1 To 3
            If tmp(t) = 1 Then tmp(t) = QUE.Dequeue()
        Next t

        sortSA tmp

        For s = 0 To 2
            If tmp(s + 1) = 0 Then
                Board(j + s, i) = vbNullString
            Else
                Board(j + s, i) = tmp(s + 1)
            End If
        Next s
    Next j
Next i

End Sub

Sub sortSA(SA As Variant)
Dim tmp As Integer

For i = 1 To 3
    For j = i To 3
        If SA(i) > SA(j) And SA(i) <> 0 And SA(j) <> 0 Then
            tmp = SA(i)
            SA(i) = SA(j)
            SA(j) = tmp
        End If
    Next j
Next i
End Sub

Sub fillQueue(ByRef Queue As Object, ByRef AR() As Integer)
Set Queue = CreateObject("System.Collections.Queue")
For i = 1 To UBound(AR)
    Queue.enqueue AR(i)
Next i
End Sub

Sub Shuffle(ByRef AR() As Integer)
Randomize
Dim Group As Integer, swapI As Integer, tmp As Integer, gs As Integer

gs = 9

For i = 1 To UBound(AR) - 1
    If i = 10 Then gs = gs + 1
    If i < 10 Then
        Group = Int((i - 1) / gs) * gs
        swapI = RNDINT(Group + gs, Group + 1)
    ElseIf i < UBound(AR) - 10 Then
        Group = Int((i) / gs) * gs
        swapI = RNDINT(Group, Group + 10)
    Else
        Group = Int((i) / gs) * gs
        swapI = RNDINT(Group, Group + 11)
    End If
    
    tmp = AR(i)
    AR(i) = AR(swapI)
    AR(swapI) = tmp
Next i
End Sub

Sub fillNums(ByRef AR() As Integer)
For i = 1 To 90: AR(i) = i: Next i
End Sub

Sub FillAnswer(Answer() As Integer)
For i = 1 To 9
    Select Case i
        Case 1
            Answer(i) = 9
        Case 9
            Answer(i) = 11
        Case Else
            Answer(i) = 10
    End Select
Next i
End Sub

Sub swap(Answer() As Integer, Totals() As Integer, Key() As Integer, Board As Variant)
Dim POS As Integer
Dim DIF As Integer
Dim tmp As Integer

For i = 1 To 9
    If Answer(i) <> Totals(i) Then
        DIF = Answer(i) - Totals(i)
        For j = 1 To 9
            POS = RNDINT(6, 1)
            If i <> j Then
                If DIF > 0 Then
                    If Answer(j) - Totals(j) < 0 Then
                        tmp = Key(POS, j)
                        Key(POS, j) = Key(POS, i)
                        Key(POS, i) = tmp
                        FillBoard Board, Key
                        SumCols Board, Totals
                        Exit For
                    End If
                Else
                    If Answer(j) - Totals(j) > 0 Then
                        tmp = Key(POS, j)
                        Key(POS, j) = Key(POS, i)
                        Key(POS, i) = tmp
                        FillBoard Board, Key
                        SumCols Board, Totals
                        Exit For
                    End If
                End If
            End If
        Next j
    End If
Next i
End Sub

Function CheckTotal(Totals() As Integer, Answer() As Integer)
Dim b As Boolean: b = True

For i = 1 To 9
    If Answer(i) <> Totals(i) Then
        b = False
        Exit For
    End If
Next i

CheckTotal = b
End Function

Sub SumCols(Board As Variant, Totals() As Integer)
Dim Total As Integer

For i = 1 To 9
    Total = 0
    For j = 1 To 18
        Total = Total + Board(j, i)
    Next j
    Totals(i) = Total
Next i
End Sub

Sub FillBoard(Board As Variant, Key() As Integer)
Dim Patterns(1 To 6) As Variant

Patterns(1) = Array(1, 0, 0)
Patterns(2) = Array(0, 1, 0)
Patterns(3) = Array(0, 0, 1)
Patterns(4) = Array(1, 1, 0)
Patterns(5) = Array(1, 0, 1)
Patterns(6) = Array(0, 1, 1)

For i = 1 To 18 Step 3
    For j = 1 To 9
        For p = 0 To 2
            Board(i + p, j) = Patterns(Key(Int((i - 1) / 3) + 1, j))(p)
        Next p
    Next j
Next i

End Sub

Sub setSix(Key() As Integer)
Dim CODES(1 To 10) As String
Dim SP() As String
Dim SEQ As Variant

CODES(1) = "1,1,1,4,5,6,6,6,6"
CODES(2) = "1,1,2,4,5,5,6,6,6"
CODES(3) = "1,1,3,4,4,5,6,6,6"
CODES(4) = "1,2,2,4,5,5,5,6,6"
CODES(5) = "1,2,3,4,4,5,5,6,6"
CODES(6) = "1,3,3,4,4,4,5,6,6"
CODES(7) = "2,2,2,4,5,5,5,5,6"
CODES(8) = "2,2,3,4,4,5,5,5,6"
CODES(9) = "2,3,3,4,4,4,5,5,6"
CODES(10) = "3,3,3,4,4,4,4,5,6"

'With Application.WorksheetFunction 'Excel 365 Dynamic Array Functions
'    SEQ = .SortBy(.Sequence(10), .RandArray(10), 1)
'End With

SEQ = RNDSEQ

For i = 1 To 6
    'SP = Split(CODES(SEQ(i, 1)), ",") '365 Version
    SP = Split(CODES(SEQ(i)), ",")
    SortSP SP
    For s = 0 To UBound(SP)
        Key(i, s + 1) = SP(s)
    Next s
Next i

End Sub

Function RNDSEQ()
Dim SEQ As Variant
Dim POS As Integer
Dim RI As Integer

SEQ = Evaluate("TRANSPOSE(INDEX(ROW(1:10),))")

For i = 1 To 10
    POS = RNDINT(10, 1)
    tmp = SEQ(POS)
    SEQ(POS) = SEQ(i)
    SEQ(i) = tmp
Next i

RNDSEQ = SEQ
End Function

Sub SortSP(SP() As String)
Dim tmp As Integer
Dim POS As Integer

For i = 0 To UBound(SP)
    POS = RNDINT(8, 0)
    tmp = SP(i)
    SP(i) = SP(POS)
    SP(POS) = tmp
Next i
End Sub

Function RNDINT(hi As Variant, lo As Variant) As Integer
RNDINT = Int(((hi + 1) - lo) * Rnd() + lo)
End Function

Sub test()
Dim SEQ As Variant
Dim POS As Integer
Dim RI As Integer

SEQ = Evaluate("TRANSPOSE(INDEX(ROW(1:10),))")

For i = 1 To 10
    POS = RNDINT(10, 1)
    tmp = SEQ(POS)
    SEQ(POS) = SEQ(i)
    SEQ(i) = tmp
Next i

End Sub

tezza · Dec 15, 2022

lrobbo314 said:
Man, did I go down the rabbit whole on this one. Combinations, permutations, a lot of banging my head.

I feel like that with much more simpler problems lol

Personally, I'm very happy with the results and your time/effort.

If you're interested I'd like to email you the actual workbook I'm working on to see what you think as I don't think I can upload the actual file here?

I'm working on a couple of upgrades and prettifying it but currently you've made it work like I wanted it to, so thank you

lrobbo314 · Dec 16, 2022

I've been on this forum for about 15 years now. It never ceases to amaze me how I keep learning. Looking back on my old code, I had learned about new and exciting tools like arraylists and queues. I was all about using those as much as I could.

I went back to this old post and wrote and re-wrote the code a few times. And after refactoring it for this last time, I got back to only using regular old arrays. Used some new tricks I've learned along the way as well.

Just love to code.

Barring any other requests for changes, this will be the last version... At least I think so.

VBA Code:

Sub Main()
TurnOff
Dim Key(1 To 6, 1 To 9) As Integer:     SetSix Key
Dim Board(1 To 18, 1 To 9) As Variant:  FillBoard Board, Key
Dim Totals(1 To 9) As Integer:          SumCols Board, Totals
Dim Answer(1 To 9) As Integer:          FillAnswer Answer
Dim AR(1 To 90) As Integer:             FillNums AR: Shuffle AR

Do Until CheckTotal(Totals, Answer)
    Swap Answer, Totals, Key, Board
    DoEvents
Loop

AddNumbers Board, AR
Range("B2:J19").Value = Board

TurnOn
End Sub

Sub AddNumbers(Board As Variant, AR() As Integer)
Dim POS As Integer:     POS = 1
Dim TMP As Variant

For i = 1 To 9
    For j = 1 To 18 Step 3
        TMP = Application.Index(Board, Array(j, j + 1, j + 2), i)
        
        For t = 1 To 3
            If TMP(t) = 1 Then
                TMP(t) = AR(POS)
                POS = POS + 1
            End If
        Next t

        SortSA TMP

        For s = 0 To 2
            If TMP(s + 1) = 0 Then
                Board(j + s, i) = vbNullString
            Else
                Board(j + s, i) = TMP(s + 1)
            End If
        Next s
        
    Next j
Next i

End Sub

Sub SortSA(SA As Variant)
Dim TMP As Integer

For i = 1 To 3
    For j = i To 3
        If SA(i) > SA(j) And SA(i) And SA(j) Then
            TMP = SA(i)
            SA(i) = SA(j)
            SA(j) = TMP
        End If
    Next j
Next i
End Sub

Sub Shuffle(ByRef AR() As Integer)
Randomize
Dim Group As Integer, swapI As Integer, TMP As Integer, GroupSize As Integer

GroupSize = 9

For i = 1 To UBound(AR) - 1
    If i = 10 Then GroupSize = GroupSize + 1
    If i < 10 Then
        Group = Int((i - 1) / GroupSize) * GroupSize
        swapI = RNDINT(Group + GroupSize, Group + 1)
    ElseIf i < UBound(AR) - 10 Then
        Group = Int((i) / GroupSize) * GroupSize
        swapI = RNDINT(Group, Group + 10)
    Else
        Group = Int((i) / GroupSize) * GroupSize
        swapI = RNDINT(Group, Group + 11)
    End If
    
    TMP = AR(i)
    AR(i) = AR(swapI)
    AR(swapI) = TMP
Next i
End Sub

Sub FillNums(ByRef AR() As Integer)
For i = 1 To 90: AR(i) = i: Next i
End Sub

Sub FillAnswer(Answer() As Integer)
For i = 1 To 9
    Select Case i
        Case 1
            Answer(i) = 9
        Case 9
            Answer(i) = 11
        Case Else
            Answer(i) = 10
    End Select
Next i
End Sub

Sub Swap(Answer() As Integer, Totals() As Integer, Key() As Integer, Board As Variant)
Dim POS As Integer
Dim DIF As Integer
Dim TMP As Integer

For i = 1 To 9
    If Answer(i) <> Totals(i) Then
        DIF = Answer(i) - Totals(i)
        For j = 1 To 9
            POS = RNDINT(6, 1)
            If i <> j Then
                If DIF > 0 Then
                    If Answer(j) - Totals(j) Then
                        TMP = Key(POS, j)
                        Key(POS, j) = Key(POS, i)
                        Key(POS, i) = TMP
                        FillBoard Board, Key
                        SumCols Board, Totals
                        Exit For
                    End If
                End If
            End If
        Next j
    End If
Next i
End Sub

Function CheckTotal(Totals() As Integer, Answer() As Integer)
Dim b As Boolean: b = True

For i = 1 To 9
    If Answer(i) <> Totals(i) Then
        b = False
        Exit For
    End If
Next i

CheckTotal = b
End Function

Sub SumCols(Board As Variant, Totals() As Integer)
Dim Total As Integer

For i = 1 To 9
    Total = 0
    For j = 1 To 18
        Total = Total + Board(j, i)
    Next j
    Totals(i) = Total
Next i
End Sub

Sub FillBoard(Board As Variant, Key() As Integer)
Dim Patterns(1 To 6) As Variant

Patterns(1) = Array(1, 0, 0)
Patterns(2) = Array(0, 1, 0)
Patterns(3) = Array(0, 0, 1)
Patterns(4) = Array(1, 1, 0)
Patterns(5) = Array(1, 0, 1)
Patterns(6) = Array(0, 1, 1)

For i = 1 To 18 Step 3
    For j = 1 To 9
        For p = 0 To 2
            Board(i + p, j) = Patterns(Key(Int((i - 1) / 3) + 1, j))(p)
        Next p
    Next j
Next i

End Sub

Sub SetSix(Key() As Integer)
Dim CODES(1 To 10) As String
Dim SP() As String
Dim SEQ As Variant

CODES(1) = "1,1,1,4,5,6,6,6,6"
CODES(2) = "1,1,2,4,5,5,6,6,6"
CODES(3) = "1,1,3,4,4,5,6,6,6"
CODES(4) = "1,2,2,4,5,5,5,6,6"
CODES(5) = "1,2,3,4,4,5,5,6,6"
CODES(6) = "1,3,3,4,4,4,5,6,6"
CODES(7) = "2,2,2,4,5,5,5,5,6"
CODES(8) = "2,2,3,4,4,5,5,5,6"
CODES(9) = "2,3,3,4,4,4,5,5,6"
CODES(10) = "3,3,3,4,4,4,4,5,6"

'With Application.WorksheetFunction 'Excel 365 Dynamic Array Functions
'    SEQ = .SortBy(.Sequence(10), .RandArray(10), 1)
'End With

SEQ = RNDSEQ

For i = 1 To 6
    'SP = Split(CODES(SEQ(i, 1)), ",") '365 Version
    SP = Split(CODES(SEQ(i)), ",")
    SortSP SP
    For s = 0 To UBound(SP)
        Key(i, s + 1) = SP(s)
    Next s
Next i

End Sub

Function RNDSEQ()
Dim SEQ As Variant
Dim POS As Integer
Dim RI As Integer

SEQ = Evaluate("TRANSPOSE(INDEX(ROW(1:10),))")

For i = 1 To 10
    POS = RNDINT(10, 1)
    TMP = SEQ(POS)
    SEQ(POS) = SEQ(i)
    SEQ(i) = TMP
Next i

RNDSEQ = SEQ
End Function

Sub SortSP(SP() As String)
Dim TMP As Integer
Dim POS As Integer

For i = 0 To UBound(SP)
    POS = RNDINT(8, 0)
    TMP = SP(i)
    SP(i) = SP(POS)
    SP(POS) = TMP
Next i
End Sub

Function RNDINT(hi As Variant, lo As Variant) As Integer
RNDINT = Int(((hi + 1) - lo) * Rnd() + lo)
End Function

Sub TurnOff()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
End Sub

Sub TurnOn()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

Peter_SSs · Dec 16, 2022

tezza said:
If you're interested I'd like to email you the actual workbook

That would not comply with #4 of the Forum Rules
However, you can upload a copy of your workbook to DropBox or OneDrive, Google Drive etc. and provide a public shared link to it here in the forum.

craigey1 · Dec 16, 2022

lrobbo314 said:
I've been on this forum for about 15 years now. It never ceases to amaze me how I keep learning. Looking back on my old code, I had learned about new and exciting tools like arraylists and queues. I was all about using those as much as I could.

I went back to this old post and wrote and re-wrote the code a few times. And after refactoring it for this last time, I got back to only using regular old arrays. Used some new tricks I've learned along the way as well.

Just love to code.

Barring any other requests for changes, this will be the last version... At least I think so.

The number generation seems a lot quicker with this code. The only thing I noticed is the numbers in each "house" are now no longer sorted Ascending.

lrobbo314 · Dec 18, 2022

I did a tad more refactoring.... But, It shouldn't have changed anything fundamentally. Don't see what you're talking about my friend. They seem to be being sorted correctly to me. Here is my latest version.

UK Bingo Ultimate No OBJ.xlsm

B

C

D

E

F

G

H

I

J

K

L

2

10

21

36

48

71

CARD 1

3

1

13

55

63

87

4

3

26

59

67

73

5

17

20

31

44

77

CARD 2

6

4

46

53

61

80

7

5

12

57

64

83

8

18

27

42

75

85

CARD 3

9

19

32

56

78

86

10

2

34

47

58

65

11

33

51

70

81

CARD 4

12

8

24

49

69

76

13

14

29

30

54

82

14

25

37

40

50

74

CARD 5

15

6

28

38

66

88

16

7

15

43

68

90

17

22

35

41

72

84

CARD 6

18

23

39

60

79

89

19

9

16

45

52

62

Bingo

VBA Code:

Sub Main()
TurnOff
Dim Key(1 To 6, 1 To 9) As Integer:     SetSix Key
Dim Board(1 To 18, 1 To 9) As Variant:  FillBoard Board, Key
Dim Totals(1 To 9) As Integer:          SumCols Board, Totals
Dim Answer(1 To 9) As Integer:          FillAnswer Answer
Dim AR(1 To 90) As Integer:             FillNums AR: Shuffle AR

Do Until CheckTotal(Totals, Answer)
    Swap Answer, Totals, Key, Board
    DoEvents
Loop

AddNumbers Board, AR
Range("B2:J19").Value = Board

TurnOn
End Sub

Sub AddNumbers(Board As Variant, AR() As Integer)
Dim POS As Integer:     POS = 1
Dim TMP As Variant

For i = 1 To 9
    For j = 1 To 18 Step 3
        TMP = Application.Index(Board, Array(j, j + 1, j + 2), i)
       
        For t = 1 To 3
            If TMP(t) = 1 Then
                TMP(t) = AR(POS)
                POS = POS + 1
            End If
        Next t

        SortSA TMP

        For s = 0 To 2
            If TMP(s + 1) = 0 Then
                Board(j + s, i) = vbNullString
            Else
                Board(j + s, i) = TMP(s + 1)
            End If
        Next s
       
    Next j
Next i

End Sub

Sub SortSA(SA As Variant)
Dim TMP As Integer

For i = 1 To 3
    For j = i To 3
        If SA(i) > SA(j) And SA(i) And SA(j) Then
            TMP = SA(i)
            SA(i) = SA(j)
            SA(j) = TMP
        End If
    Next j
Next i
End Sub

Sub Shuffle(ByRef AR() As Integer)
Randomize
Dim Group As Integer, swapI As Integer, TMP As Integer, GroupSize As Integer

GroupSize = 9

For i = 1 To UBound(AR) - 1
    If i = 10 Then GroupSize = GroupSize + 1
    If i < 10 Then
        Group = Int((i - 1) / GroupSize) * GroupSize
        swapI = RNDINT(Group + GroupSize, Group + 1)
    ElseIf i < UBound(AR) - 10 Then
        Group = Int((i) / GroupSize) * GroupSize
        swapI = RNDINT(Group, Group + 10)
    Else
        Group = Int((i) / GroupSize) * GroupSize
        swapI = RNDINT(Group, Group + 11)
    End If
   
    TMP = AR(i)
    AR(i) = AR(swapI)
    AR(swapI) = TMP
Next i
End Sub

Sub FillNums(ByRef AR() As Integer)
For i = 1 To 90: AR(i) = i: Next i
End Sub

Sub FillAnswer(Answer() As Integer)
For i = 1 To 9
    Select Case i
        Case 1
            Answer(i) = 9
        Case 9
            Answer(i) = 11
        Case Else
            Answer(i) = 10
    End Select
Next i
End Sub

Sub Swap(Answer() As Integer, Totals() As Integer, Key() As Integer, Board As Variant)
Dim POS As Integer
Dim DIF As Integer
Dim TMP As Integer

For i = 1 To 9
    If Answer(i) - Totals(i) Then
        DIF = Answer(i) - Totals(i)
        For j = 1 To 9
            POS = RNDINT(6, 1)
            If i <> j Then
                If Answer(j) - Totals(j) Then
                    TMP = Key(POS, j)
                    Key(POS, j) = Key(POS, i)
                    Key(POS, i) = TMP
                    FillBoard Board, Key
                    SumCols Board, Totals
                    Exit For
                End If
            End If
        Next j
    End If
Next i
End Sub

Function CheckTotal(Totals() As Integer, Answer() As Integer)
Dim b As Boolean: b = True

For i = 1 To 9
    If Answer(i) <> Totals(i) Then
        b = False
        Exit For
    End If
Next i

CheckTotal = b
End Function

Sub SumCols(Board As Variant, Totals() As Integer)
Dim Total As Integer

For i = 1 To 9
    Total = 0
    For j = 1 To 18
        Total = Total + Board(j, i)
    Next j
    Totals(i) = Total
Next i
End Sub

Sub FillBoard(Board As Variant, Key() As Integer)
Dim Patterns(1 To 6) As Variant

Patterns(1) = Array(1, 0, 0)
Patterns(2) = Array(0, 1, 0)
Patterns(3) = Array(0, 0, 1)
Patterns(4) = Array(1, 1, 0)
Patterns(5) = Array(1, 0, 1)
Patterns(6) = Array(0, 1, 1)

For i = 1 To 18 Step 3
    For j = 1 To 9
        For p = 0 To 2
            Board(i + p, j) = Patterns(Key(Int((i - 1) / 3) + 1, j))(p)
        Next p
    Next j
Next i

End Sub

Sub SetSix(Key() As Integer)
Dim CODES(1 To 10) As String
Dim SP() As String
Dim SEQ As Variant

CODES(1) = "1,1,1,4,5,6,6,6,6"
CODES(2) = "1,1,2,4,5,5,6,6,6"
CODES(3) = "1,1,3,4,4,5,6,6,6"
CODES(4) = "1,2,2,4,5,5,5,6,6"
CODES(5) = "1,2,3,4,4,5,5,6,6"
CODES(6) = "1,3,3,4,4,4,5,6,6"
CODES(7) = "2,2,2,4,5,5,5,5,6"
CODES(8) = "2,2,3,4,4,5,5,5,6"
CODES(9) = "2,3,3,4,4,4,5,5,6"
CODES(10) = "3,3,3,4,4,4,4,5,6"

'With Application.WorksheetFunction 'Excel 365 Dynamic Array Functions
'    SEQ = .SortBy(.Sequence(10), .RandArray(10), 1)
'End With

SEQ = RNDSEQ

For i = 1 To 6
    'SP = Split(CODES(SEQ(i, 1)), ",") '365 Version
    SP = Split(CODES(SEQ(i)), ",")
    SortSP SP
    For s = 0 To UBound(SP)
        Key(i, s + 1) = SP(s)
    Next s
Next i

End Sub

Function RNDSEQ()
Dim SEQ As Variant
Dim POS As Integer
Dim RI As Integer

SEQ = Evaluate("TRANSPOSE(INDEX(ROW(1:10),))")

For i = 1 To 10
    POS = RNDINT(10, 1)
    TMP = SEQ(POS)
    SEQ(POS) = SEQ(i)
    SEQ(i) = TMP
Next i

RNDSEQ = SEQ
End Function

Sub SortSP(SP() As String)
Dim TMP As Integer
Dim POS As Integer

For i = 0 To UBound(SP)
    POS = RNDINT(8, 0)
    TMP = SP(i)
    SP(i) = SP(POS)
    SP(POS) = TMP
Next i
End Sub

Function RNDINT(hi As Variant, lo As Variant) As Integer
RNDINT = Int(((hi + 1) - lo) * Rnd() + lo)
End Function

Sub TurnOff()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
End Sub

Sub TurnOn()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

craigey1 · Dec 18, 2022

lrobbo314 said:
I did a tad more refactoring.... But, It shouldn't have changed anything fundamentally. Don't see what you're talking about my friend. They seem to be being sorted correctly to me. Here is my latest version.

I'm not sure what's going wrong - It seems to work on the first sheet fine, but when running the sub Main for each each of the 8 sheets, I get at least one sheet, but usually more where one or two of the houses have the numbers in the 1-9 column sorted descending - everything else on all other columns & all other sheets is correct.

I'm using this to call the Main sun across all 8 sheets

VBA Code:

Sub Generate_Bingo_Ticket_Numbers()
Dim Ws As Worksheet
For Each Ws In Worksheets
If InStr(1, Ws.Name, "Sheet", vbBinaryCompare) = 1 Then
Ws.Activate
Main
End If
Next Ws
Sheet1.Activate
End Sub

I've uploaded a screenshot of sheet 2, showing House 2 & 5 with the issue in the 1-9 column

lrobbo314 · Dec 18, 2022

Here is how I wrote it for multiple sheets. Seem to be working the way that it should.

VBA Code:

Sub Generate()
Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets
    Main ws
Next ws
End Sub

Sub Main(ws As Worksheet)
TurnOff
Dim Key(1 To 6, 1 To 9) As Integer:     SetSix Key
Dim Board(1 To 18, 1 To 9) As Variant:  FillBoard Board, Key
Dim Totals(1 To 9) As Integer:          SumCols Board, Totals
Dim Answer(1 To 9) As Integer:          FillAnswer Answer
Dim AR(1 To 90) As Integer:             FillNums AR: Shuffle AR

Do Until CheckTotal(Totals, Answer)
    Swap Answer, Totals, Key, Board
    DoEvents
Loop

AddNumbers Board, AR
ws.Range("B2:J19").Value = Board

TurnOn
End Sub

Sub AddNumbers(Board As Variant, AR() As Integer)
Dim POS As Integer:     POS = 1
Dim TMP As Variant

For i = 1 To 9
    For j = 1 To 18 Step 3
        TMP = Application.Index(Board, Array(j, j + 1, j + 2), i)
       
        For t = 1 To 3
            If TMP(t) = 1 Then
                TMP(t) = AR(POS)
                POS = POS + 1
            End If
        Next t

        SortSA TMP

        For s = 0 To 2
            If TMP(s + 1) = 0 Then
                Board(j + s, i) = vbNullString
            Else
                Board(j + s, i) = TMP(s + 1)
            End If
        Next s
       
    Next j
Next i

End Sub

Sub SortSA(SA As Variant)
Dim TMP As Integer

For i = 1 To 3
    For j = i To 3
        If SA(i) > SA(j) And SA(i) And SA(j) Then
            TMP = SA(i)
            SA(i) = SA(j)
            SA(j) = TMP
        End If
    Next j
Next i
End Sub

Sub Shuffle(ByRef AR() As Integer)
Randomize
Dim Group As Integer, swapI As Integer, TMP As Integer, GroupSize As Integer

GroupSize = 9

For i = 1 To UBound(AR) - 1
    If i = 10 Then GroupSize = GroupSize + 1
    If i < 10 Then
        Group = Int((i - 1) / GroupSize) * GroupSize
        swapI = RNDINT(Group + GroupSize, Group + 1)
    ElseIf i < UBound(AR) - 10 Then
        Group = Int((i) / GroupSize) * GroupSize
        swapI = RNDINT(Group, Group + 10)
    Else
        Group = Int((i) / GroupSize) * GroupSize
        swapI = RNDINT(Group, Group + 11)
    End If
   
    TMP = AR(i)
    AR(i) = AR(swapI)
    AR(swapI) = TMP
Next i
End Sub

Sub FillNums(ByRef AR() As Integer)
For i = 1 To 90: AR(i) = i: Next i
End Sub

Sub FillAnswer(Answer() As Integer)
For i = 1 To 9
    Select Case i
        Case 1
            Answer(i) = 9
        Case 9
            Answer(i) = 11
        Case Else
            Answer(i) = 10
    End Select
Next i
End Sub

Sub Swap(Answer() As Integer, Totals() As Integer, Key() As Integer, Board As Variant)
Dim POS As Integer
Dim DIF As Integer
Dim TMP As Integer

For i = 1 To 9
    If Answer(i) - Totals(i) Then
        DIF = Answer(i) - Totals(i)
        For j = 1 To 9
            POS = RNDINT(6, 1)
            If i <> j Then
                If Answer(j) - Totals(j) Then
                    TMP = Key(POS, j)
                    Key(POS, j) = Key(POS, i)
                    Key(POS, i) = TMP
                    FillBoard Board, Key
                    SumCols Board, Totals
                    Exit For
                End If
            End If
        Next j
    End If
Next i
End Sub

Function CheckTotal(Totals() As Integer, Answer() As Integer)
Dim b As Boolean: b = True

For i = 1 To 9
    If Answer(i) <> Totals(i) Then
        b = False
        Exit For
    End If
Next i

CheckTotal = b
End Function

Sub SumCols(Board As Variant, Totals() As Integer)
Dim Total As Integer

For i = 1 To 9
    Total = 0
    For j = 1 To 18
        Total = Total + Board(j, i)
    Next j
    Totals(i) = Total
Next i
End Sub

Sub FillBoard(Board As Variant, Key() As Integer)
Dim Patterns(1 To 6) As Variant

Patterns(1) = Array(1, 0, 0)
Patterns(2) = Array(0, 1, 0)
Patterns(3) = Array(0, 0, 1)
Patterns(4) = Array(1, 1, 0)
Patterns(5) = Array(1, 0, 1)
Patterns(6) = Array(0, 1, 1)

For i = 1 To 18 Step 3
    For j = 1 To 9
        For p = 0 To 2
            Board(i + p, j) = Patterns(Key(Int((i - 1) / 3) + 1, j))(p)
        Next p
    Next j
Next i

End Sub

Sub SetSix(Key() As Integer)
Dim CODES(1 To 10) As String
Dim SP() As String
Dim SEQ As Variant

CODES(1) = "1,1,1,4,5,6,6,6,6"
CODES(2) = "1,1,2,4,5,5,6,6,6"
CODES(3) = "1,1,3,4,4,5,6,6,6"
CODES(4) = "1,2,2,4,5,5,5,6,6"
CODES(5) = "1,2,3,4,4,5,5,6,6"
CODES(6) = "1,3,3,4,4,4,5,6,6"
CODES(7) = "2,2,2,4,5,5,5,5,6"
CODES(8) = "2,2,3,4,4,5,5,5,6"
CODES(9) = "2,3,3,4,4,4,5,5,6"
CODES(10) = "3,3,3,4,4,4,4,5,6"

'With Application.WorksheetFunction 'Excel 365 Dynamic Array Functions
'    SEQ = .SortBy(.Sequence(10), .RandArray(10), 1)
'End With

SEQ = RNDSEQ

For i = 1 To 6
    'SP = Split(CODES(SEQ(i, 1)), ",") '365 Version
    SP = Split(CODES(SEQ(i)), ",")
    SortSP SP
    For s = 0 To UBound(SP)
        Key(i, s + 1) = SP(s)
    Next s
Next i

End Sub

Function RNDSEQ()
Dim SEQ As Variant
Dim POS As Integer
Dim RI As Integer

SEQ = Evaluate("TRANSPOSE(INDEX(ROW(1:10),))")

For i = 1 To 10
    POS = RNDINT(10, 1)
    TMP = SEQ(POS)
    SEQ(POS) = SEQ(i)
    SEQ(i) = TMP
Next i

RNDSEQ = SEQ
End Function

Sub SortSP(SP() As String)
Dim TMP As Integer
Dim POS As Integer

For i = 0 To UBound(SP)
    POS = RNDINT(8, 0)
    TMP = SP(i)
    SP(i) = SP(POS)
    SP(POS) = TMP
Next i
End Sub

Function RNDINT(hi As Variant, lo As Variant) As Integer
RNDINT = Int(((hi + 1) - lo) * Rnd() + lo)
End Function

Sub TurnOff()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
End Sub

Sub TurnOn()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

craigey1 · Dec 18, 2022

lrobbo314 said:
Here is how I wrote it for multiple sheets. Seem to be working the way that it should.

I think the issue is that I'm using the sheet range A1:J18 which is where my Bingo cards are - It seems to work fine if using B2:J19

UK Bingo cards

craigey1

New Member

Attachments

tezza

Active Member

Attachments

Excel Facts

lrobbo314

Well-known Member

tezza

Active Member

lrobbo314

Well-known Member

Peter_SSs

MrExcel MVP, Moderator

craigey1

New Member

lrobbo314

Well-known Member

craigey1

New Member

Attachments

lrobbo314

Well-known Member

craigey1

New Member

Similar threads

Forum statistics

Share this page

UK Bingo cards

New Member

Attachments

Active Member

Attachments

Excel Facts

Well-known Member

Active Member

Well-known Member

MrExcel MVP, Moderator

New Member

Well-known Member

New Member

Attachments

Well-known Member

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock