UK Bingo cards

[craigey1]

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]

Nope, my fault. Missed a function. Paste the code in below the rest of the code and it should work.

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

That's better

It does still group 3 in one Col though (I actually didn't realise that myself until it was mentioned here). Like B4:B6

I now puts more that 5 in a row too unfortunately.

 

[lrobbo314]

I am completely unfamiliar with the game. From what I could understand, this latest iteration was how it was supposed to work. Even on the original you can spot 4 in a row. My understanding was that these were 6 separate cards and even if you have 3 in a row on 1 card, it wouldn't matter if there were more in a row above or below it.

 

[tezza]

I am completely unfamiliar with the game. From what I could understand, this latest iteration was how it was supposed to work. Even on the original you can spot 4 in a row. My understanding was that these were 6 separate cards and even if you have 3 in a row on 1 card, it wouldn't matter if there were more in a row above or below it.

This is probably the best line to follow:

An individual box has 15 numbers, 5 per row and between 0 and 2 per column

Above is 6 games

Col K should always count 5 numbers in a line

Col L should always count 15 in a game, in this case rows 2-4, 5-7, 8-10, 11-13, 14-16 & 17-19

Never 3 in the same Col per game card

So D2:D4 has 3 in a Col in 1 game so that is wrong, but you can have 3 directly in a line if it was D3:D5 as it overlaps into 2 games. So G3-G6 is fine.

Hope that helps a little.

 

[tezza]

I've done a bit more research and I don't believe that having 3 in a Col in 1 game is wrong.

It looks like you must have at least 1 number is every Col per game. So you're original code was almost there.

This a game from your original code:

The ONLY thing that fails here is in game 2 where there's nothing in the 40's Col, other than that it works great.

 

[tezza]

Hmmm, I think that was my fault as I missed the fact that the bottom row wasn't updating. It's been running perfectly every since.

So, the original code for the win.

I just need to get it to run on the laptop now where it fails at

Set Patterns = CreateObject("System.Collections.ArrayList")

 

[craigey1]

I'm not sure if it having 3 numbers in a column per house (each segment made up of 3 lines is known as a house) is correct or not. I can see Wikipedia says it's allowed, but most bingo cards I've seen & played on have up to 2 per column - I can see that some print at home tickets do have 3 per column as well so maybe it's just a question of readability?

The only thing I have noticed that's different & TBH I don't think really makes a difference, is that the numbers in a column should be in ascending order per house, so in Tezza's example on post #24 for the first Column (M) these would swap:
M4 should be 1 & M5 should be 6
M7 should be 2 & M9 should be 5

 

[lrobbo314]

Alright. Well, it seems like no one is a big fan of having 3 numbers in the house. I took that out and made it sort the values in each house in ascending order.

UK Bingo II.xlsm
	A	B	C	D	E	F	G	H	I
1		11		37			60	78
2	2			39	43	53			81
3	6	13	27			59	62	79	82
4		17	25			55	63		85
5	4		28	30	41			76
6	8			36	44		67		87
7		10		31	42		64
8	5		22	38		54	68	70	86
9		16	29			56		72	88
10				32	48	51
11	3	14	26				65	75
12		15		35	49	52		77	83
13		18	20		46	57		71
14	1	19		34		58			80
15	9		24		47		66	73	84
16		12	21		40		61
17				33	45		69		89
18	7		23			50		74	90
Sheet3

Sub QMAIN()
Application.ScreenUpdating = False
Dim Output(1 To 18, 1 To 9) As Variant
Dim r As Range:                 Set r = Range("A1").Resize(UBound(Output), UBound(Output, 2))
Dim AR(1 To 90) As Integer:     fillNums AR: Shuffle AR
Dim QUE As Object:              fillQueue QUE, AR
Dim PAT As Object

r.ClearContents
FillOutput QUE, Output, PAT
r.Value = Output
Application.ScreenUpdating = True
End Sub

Sub NumPatterns(ByRef PAT As Object, Total As Integer)
Set PAT = CreateObject("System.Collections.ArrayList")

Select Case Total
    Case 9
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 0, 0)
        PAT.Add Array(1, 0, 0)
        PAT.Add Array(1, 0, 0)
    Case 10
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 0, 0)
        PAT.Add Array(1, 0, 0)
    Case 11
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 0, 0)
End Select
        
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 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 FillOutput(QUE As Object, Output As Variant, PAT As Object)
Dim i As Integer

For i = 1 To 9
    MatchPat i, PAT, QUE, Output
    PAT.Clear
    'COL = COL + 1
Next i
    
End Sub

Sub MatchPat(COL As Integer, PAT As Object, QUE As Object, Output As Variant)
Dim Total As Integer
Dim RP As Integer
Dim PA As Variant
Dim RG As Integer:      RG = 1
Dim RO As Integer:      RO = 1
Dim SA(0 To 2) As Variant

Select Case COL
    Case 1
        Total = 9
    Case 9
        Total = 11
    Case Else
        Total = 10
End Select

NumPatterns PAT, Total

Do Until PAT.Count = 0
    RP = getRnd(PAT.Count - 1, 0)
    PA = PAT(RP)
    PAT.removeat (RP)
    MIXLAST PA
    
    For p = 0 To 2
        'If PA(p) = 1 Then Output(p + RG, COL) = QUE.deQueue()
        If PA(p) = 1 Then SA(p) = QUE.Dequeue()
    Next p
    
    SortAR SA
    
    For i = 0 To 2
        If SA(i) > 0 Then Output(i + RG, COL) = SA(i)
    Next i
    
    Erase SA
    
    RG = RG + 3
Loop

End Sub

Sub SortAR(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 MIXLAST(tmp As Variant)
Dim t As Integer
Dim v As Integer

For i = 0 To 2
    t = getRnd(2, 0)
    v = tmp(i)
    tmp(i) = tmp(t)
    tmp(t) = v
Next i
End Sub

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

 

[tezza]

Alright. Well, it seems like no one is a big fan of having 3 numbers in the house. I took that out and made it sort the values in each house in ascending order.

UK Bingo II.xlsm
	A	B	C	D	E	F	G	H	I
1		11		37			60	78
2	2			39	43	53			81
3	6	13	27			59	62	79	82
4		17	25			55	63		85
5	4		28	30	41			76
6	8			36	44		67		87
7		10		31	42		64
8	5		22	38		54	68	70	86
9		16	29			56		72	88
10				32	48	51
11	3	14	26				65	75
12		15		35	49	52		77	83
13		18	20		46	57		71
14	1	19		34		58			80
15	9		24		47		66	73	84
16		12	21		40		61
17				33	45		69		89
18	7		23			50		74	90
Sheet3

Sub QMAIN()
Application.ScreenUpdating = False
Dim Output(1 To 18, 1 To 9) As Variant
Dim r As Range:                 Set r = Range("A1").Resize(UBound(Output), UBound(Output, 2))
Dim AR(1 To 90) As Integer:     fillNums AR: Shuffle AR
Dim QUE As Object:              fillQueue QUE, AR
Dim PAT As Object

r.ClearContents
FillOutput QUE, Output, PAT
r.Value = Output
Application.ScreenUpdating = True
End Sub

Sub NumPatterns(ByRef PAT As Object, Total As Integer)
Set PAT = CreateObject("System.Collections.ArrayList")

Select Case Total
    Case 9
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 0, 0)
        PAT.Add Array(1, 0, 0)
        PAT.Add Array(1, 0, 0)
    Case 10
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 0, 0)
        PAT.Add Array(1, 0, 0)
    Case 11
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 1, 0)
        PAT.Add Array(1, 0, 0)
End Select
      
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 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 FillOutput(QUE As Object, Output As Variant, PAT As Object)
Dim i As Integer

For i = 1 To 9
    MatchPat i, PAT, QUE, Output
    PAT.Clear
    'COL = COL + 1
Next i
  
End Sub

Sub MatchPat(COL As Integer, PAT As Object, QUE As Object, Output As Variant)
Dim Total As Integer
Dim RP As Integer
Dim PA As Variant
Dim RG As Integer:      RG = 1
Dim RO As Integer:      RO = 1
Dim SA(0 To 2) As Variant

Select Case COL
    Case 1
        Total = 9
    Case 9
        Total = 11
    Case Else
        Total = 10
End Select

NumPatterns PAT, Total

Do Until PAT.Count = 0
    RP = getRnd(PAT.Count - 1, 0)
    PA = PAT(RP)
    PAT.removeat (RP)
    MIXLAST PA
  
    For p = 0 To 2
        'If PA(p) = 1 Then Output(p + RG, COL) = QUE.deQueue()
        If PA(p) = 1 Then SA(p) = QUE.Dequeue()
    Next p
  
    SortAR SA
  
    For i = 0 To 2
        If SA(i) > 0 Then Output(i + RG, COL) = SA(i)
    Next i
  
    Erase SA
  
    RG = RG + 3
Loop

End Sub

Sub SortAR(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 MIXLAST(tmp As Variant)
Dim t As Integer
Dim v As Integer

For i = 0 To 2
    t = getRnd(2, 0)
    v = tmp(i)
    tmp(i) = tmp(t)
    tmp(t) = v
Next i
End Sub

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

That solves the 3 issue

The next one is each line must have 5 numbers and each game must have 15 numbers (like your old version)

Your current code returns the following:

Sorry, I bet you'd wish you ignored my pm now lol

 

[tezza]

@lrobbo314

All that's needed is a sort in your old post and it's perfect.

UK Bingo cards

My original query was about not being able to run on my laptop but now that I've ticked .netframework 3.5 it runs smoothly.

 

[lrobbo314]

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	1		27	31	41			74			5	4
2			28	39	45	57	61				5	4
3	6	15					66	77	81		5	4
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		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	9	10	10	10	10	10	10	10	11
21	9	8	8	8	8	8	8	8	7
22
23	1	10	20	30	40	50	60	70	80
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.

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