# 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


----------



## braindiesel

Interesting, and not sure if I will get it but looks like a good challenge.
Question...
Is it possible that a cardhave a column with 3 numbers in it and anotehr columne has 0 numbers in it


----------



## craigey1

No - It'll have at least 1 number, but a maximum of 2.


----------



## craigey1

Sorry can't seem to edit the post - Originally post says:
3. An individual box has 15 numbers, 5 per row and between 0 and 2 per column 
but it should say between 1 and 2 per column


----------



## Dave Patton

check the following site to see if the ideas help





						Create Bingo Cards in Excel – Contextures Blog
					






					contexturesblog.com


----------



## craigey1

Dave Patton said:


> check the following site to see if the ideas help
> 
> 
> 
> 
> 
> Create Bingo Cards in Excel – Contextures Blog
> 
> 
> 
> 
> 
> 
> 
> contexturesblog.com


I've given that a go & managed to get a 3 * 9 grid populated with the appropriate numbers.  I got 2 cards to be generated from the same numbers table, but a 3rd always produced a NUM! error on all but the last column - I suspect due to the additional number 90 in the table.

I'm not sure how I'd then go about adding in the blank spaces or how to generate the additional cards using the unused numbers or how to reuse the numbers that would be covered over when inserting the blanks.


----------



## Dave Patton

Hello *craigey1*
I never tried to create the Bingo cards. I just recalled that Debra had an example on her site.
If you are still having troubles, you can post an example with XL2BB. Please describe your problem and
explain what is different in your sheet compared to Debra's.

Hopefully someone will be able to answer your questions.


----------



## craigey1

TBH I thought the screenshots would help with clarifying the issue.  The formula on the link you provided uses INDEX / Match & all I've done it adjusted the cell vales it looks for.
Anyway here goes:
Cards sheet has:
BingoCard.xlsABCDEFGHIJ124162936445664758532102834495260778949182630465066708456781321374755617281811222334158627388931725324851677687101112########################################8613#############################################14#############################################CardsCell FormulasRangeFormulaB12:B14,B7:B9,B2:B4B2=INDEX(Numbers!$A$1:$A$9,MATCH(LARGE(Numbers!$B$1:$B$9,ROW()-1),Numbers!$B$1:$B$9,0))C12:C14,C7:C9,C2:C4C2=INDEX(Numbers!$D$1:$D$10,MATCH(LARGE(Numbers!$E$1:$E$10,ROW()-1),Numbers!$E$1:$E$10,0))D12:D14,D7:D9,D2:D4D2=INDEX(Numbers!$G$1:$G$10,MATCH(LARGE(Numbers!$H$1:$H$10,ROW()-1),Numbers!$H$1:$H$10,0))E12:E14,E7:E9,E2:E4E2=INDEX(Numbers!$J$1:$J$10,MATCH(LARGE(Numbers!$K$1:$K$10,ROW()-1),Numbers!$K$1:$K$10,0))F12:F14,F7:F9,F2:F4F2=INDEX(Numbers!$M$1:$M$10,MATCH(LARGE(Numbers!$N$1:$N$10,ROW()-1),Numbers!$N$1:$N$10,0))G12:G14,G7:G9,G2:G4G2=INDEX(Numbers!$P$1:$P$10,MATCH(LARGE(Numbers!$Q$1:$Q$10,ROW()-1),Numbers!$Q$1:$Q$10,0))H12:H14,H7:H9,H2:H4H2=INDEX(Numbers!$S$1:$S$10,MATCH(LARGE(Numbers!$T$1:$T$10,ROW()-1),Numbers!$T$1:$T$10,0))I12:I14,I7:I9,I2:I4I2=INDEX(Numbers!$V$1:$V$10,MATCH(LARGE(Numbers!$W$1:$W$10,ROW()-1),Numbers!$W$1:$W$10,0))J12:J14,J7:J9,J2:J4J2=INDEX(Numbers!$Y$1:$Y$11,MATCH(LARGE(Numbers!$Z$1:$Z$11,ROW()-1),Numbers!$Z$1:$Z$11,0))

Numbers sheet has:
BingoCard.xlsABCDEFGHIJKLMNOPQRSTUVWXYZ110.372100.919200.061300.726400.795500.812600.843700.65800.555220.772110.677210.264310.658410.362510.262610.585710.618810.407330.317120.496220.225320.549420.617520.826620.553720.48820.248440.98130.532230.003330.579430.338530.732630.652730.309830.164550.654140.017240.455340.754440.961540.728640.912740.208840.57660.612150.831250.074350.134450.036550.663650.139750.85850.723770.284160.997260.658360.829460.831560.971660.839760.279860.094880.48170.255270.495370.598470.467570.213670.506770.821870.26990.72180.901280.726380.666480.356580.615680.744780.6880.38810190.113290.894390.388490.959590.165690.203790.124890.72211900.411NumbersCell FormulasRangeFormulaZ1:Z11,W1:W10,T1:T10,Q1:Q10,N1:N10,K1:K10,H1:H10,E1:E10,B1:B9B1=RAND()


----------



## lrobbo314

You can use the code below.  You can speed it up a bit by turning screenupdating off, but I kind of liked the effect of the code running through the cards.

20200407 MXL Bingo.xlsmABCDEFGHIJ15243649707787Card 12182160323346516246164273Card 2522395565756915345869857144482Card 381017293141576381928597910122738437486Card 41120485664841242566721334588Card 51413233776901511940475461711681126355053677883Card 617325268187308089Sheet2



		VBA Code:
__


Sub Main()
Dim AR() As Variant: ReDim AR(1 To 18, 1 To 9)
Dim AVAIL As Object: setAvail AVAIL
Dim NUMS As Object: setNums NUMS
Dim SP() As String
Dim Card As Integer, Spot As Integer, rNum As Integer
Dim CD As Integer: CD = 9
Dim Col As Integer: Col = 1
Dim b As Boolean: b = False

Do
    Do Until Col > 9
        Card = AVAIL.keys()(getRand(AVAIL.Count - 1, 0))
        Do
            SP = Split(AVAIL(Card), "-")
            Spot = getRand(SP(1), SP(0))
        Loop Until AR(Spot, Col) = vbNullString
        rNum = getRand(CD, 0)
        AR(Spot, Col) = NUMS(rNum)
        If Not checkCard(AR, SP(1), SP(0), Col) Then AVAIL.Remove Card
        NUMS.Remove NUMS(rNum)
        CD = CD - 1
        If CD < 0 Then
            CD = 9
            setAvail AVAIL
            Col = Col + 1
        End If
    Loop
    Range("A1:I18") = AR
    If Not finalCheck Then
        Reset AVAIL, NUMS, AR, Col, CD
    Else
        b = True
    End If
Loop Until b = True
       
End Sub

Sub Reset(ByRef AVAIL As Object, ByRef NUMS As Object, ByRef AR() As Variant, ByRef Col As Integer, ByRef CD As Integer)
setAvail AVAIL
setNums NUMS
Col = 1
CD = 9
ReDim AR(1 To 18, 1 To 9)
Range("A1:I18").ClearContents
End Sub

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

Sub setAvail(ByRef AVAIL As Object)
Set AVAIL = CreateObject("Scripting.Dictionary")
Dim id As Integer: id = 0
For i = 0 To 17 Step 3: AVAIL.Add id, Join(Array(i + 1, i + 3), "-"): id = id + 1: Next i
End Sub

Sub setNums(ByRef NUMS As Object)
Set NUMS = CreateObject("System.Collections.ArrayList")
For i = 1 To 90: NUMS.Add i: Next i
End Sub

Function checkCard(ByRef AR() As Variant, hi As Variant, lo As Variant, Col As Integer) As Boolean
Dim total As Integer: total = 0
For i = lo To hi
    If AR(i, Col) <> vbNullString Then
        total = total + 1
    End If
Next i
checkCard = total < 2
End Function

Function finalCheck() As Boolean
Dim r As Range
Dim b As Boolean: b = True
ActiveSheet.UsedRange.Interior.ColorIndex = -4142
For Ro = 1 To 18 Step 3
    For Col = 1 To 9
        Set r = Range(Cells(Ro, Col), Cells(Ro + 2, Col))
        If Application.WorksheetFunction.CountBlank(r) = 3 Then finalCheck = False: Exit Function
    Next Col
Next Ro
finalCheck = b
End Function


----------



## craigey1

lrobbo314 said:


> You can use the code below.  You can speed it up a bit by turning screenupdating off, but I kind of liked the effect of the code running through the cards.
> ....



Thanks - I haven't had a chance to look through this yet, but it looks like it could be just the job.  Very much appreciated, Sir!


----------



## 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


----------



## lrobbo314

Cool. Glad to hear it.  Even though I kinda dig the effects of the first one, the effects are caused by it iterating over and over until it finds something that works.  The version below doesn't need to do that.  This will be faster and more efficient.



		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 Ones As Object:             fillOne Ones
Dim Twos As Object:             fillTwo Twos
Dim Queue As Object

Shuffle AR
fillQueue Queue, AR
fillArray Result, Queue, Ones, Twos
fillOutput Result, Output
Range("A1").Resize(UBound(Output, 1), UBound(Output, 2)).Value2 = Output
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

For i = 1 To UBound(AR)
    Group = Int((i - 1) / 10) * 10
    Swap = getRnd(Group + 10, Group + 1)
    tmp = AR(i)
    AR(i) = AR(Swap)
    AR(Swap) = tmp
Next i
End Sub

Sub fillOne(ByRef Pat As Object)
Set Pat = CreateObject("System.Collections.ArrayList")
For i = 1 To 18
    Select Case Rnd()
        Case Is < 0.333
            Pat.Add Array(1, 0, 0)
        Case Is < 0.666
            Pat.Add Array(0, 1, 0)
        Case Is < 1
            Pat.Add Array(0, 0, 1)
    End Select
Next i
End Sub

Sub fillTwo(ByRef Pat As Object)
Set Pat = CreateObject("System.Collections.ArrayList")
For j = 1 To 36
    Select Case Rnd()
        Case Is < 0.333
            Pat.Add Array(1, 1, 0)
        Case Is < 0.666
            Pat.Add Array(0, 1, 1)
        Case Is < 1
            Pat.Add Array(1, 0, 1)
    End Select
Next j
End Sub

Sub fillArray(ByRef Result() As Variant, Queue As Object, ByRef Ones As Object, Twos As Object)
Dim RN As Integer: RN = 0
Dim Pos As Integer: Pos = 1
Dim tmp As Variant
Dim Pat As Variant: Pat = Split(StrConv("112222", vbUnicode), Chr(0))

ReDim Preserve Pat(0 To UBound(Pat) - 1)
ShuffleOnesTwos Pat

For i = 1 To 9
    For j = LBound(Pat) To UBound(Pat)
        If Pat(j) = 1 Then
            tmp = Ones(getRnd(Ones.Count - 1, 0))
        Else
            tmp = Twos(getRnd(Twos.Count - 1, 0))
        End If
        For k = LBound(tmp) To UBound(tmp)
            If tmp(k) = 1 Then
                Result(Pos) = Queue.dequeue()
            Else
                Result(Pos) = vbNullString
            End If
            Pos = Pos + 1
        Next k
    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


----------



## Peter_SSs

@lrobbo314
It appears to me that your codes do not take account of this requirement?



craigey1 said:


> 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:
> 
> 3. *An individual box has *15 numbers,* 5 per row* and between 0 and 2 per column


----------



## Sanjeev1976

craigey1 said:


> 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


Check the below link from Chandoo.org









						Print Housie Tickets Free - Excel Template for Housie Tickets (Bingo Tickets)
					

Print housie tickets using this excel sheet. To get new tickets, just press F9. Generate unlimited number of tickets and enjoy. Have fun playing housie / bino with your friends (or family) instantly using this excel template for printable housie ticket generator.




					chandoo.org


----------



## craigey1

Sanjeev1976 said:


> Check the below link from Chandoo.org


Thanks, but I've tried that site already - it only produces individual cards, rather than the set of 6.


----------



## craigey1

Peter_SSs said:


> @lrobbo314
> It appears to me that your codes do not take account of this requirement?



Unfortunately Peter_SSs is correct - @lrobbo314 's solution is very close, but each card should contain 15 numbers, 5 numbers & 4 blanks per row and have between 1 and 3 Numbers per column (or 1 or 2 blanks per column).

The only other thing I noticed is that column 1 is going up to 10, but should only be 1 to 9, the 10 should be in the 2nd column, 20 should be in the 3rd etc (so all the 40's are in the sme column, all the 50's in the next etc - only the last column would contain all the 80's & the number 90).   I guess this would need an if col < 8 statement somewhere in the vbs.


----------



## lrobbo314

Small code revision.  This version seems to do the trick.

20200407 MXL Bingo.xlsmABCDEFGHIJ110446585Card 12162442556236132336728942237496387Card 2591133516673634354717207783Card 3873546606479922840455681101827677682Card 411172932505370861243459131238587488Card 51453039486115142552687816121577584Card 617192631476980188154190Sheet2



		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 Ones As Object:             fillOne Ones
Dim Twos As Object:             fillTwo Twos
Dim Patterns As Object:         setPatterns Patterns
Dim Queue As Object

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

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

Patterns.Add Array(2, 2, 2, 1, 1, 2)
Patterns.Add Array(2, 2, 2, 1, 1, 2)
Patterns.Add Array(1, 2, 2, 2, 2, 1)
Patterns.Add Array(1, 2, 2, 1, 2, 2)
Patterns.Add Array(2, 1, 2, 2, 1, 2)
Patterns.Add Array(2, 2, 1, 2, 2, 1)
Patterns.Add Array(1, 2, 2, 2, 2, 1)
Patterns.Add Array(2, 1, 1, 2, 2, 2)
Patterns.Add Array(2, 1, 1, 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

For i = 1 To UBound(AR)
    Group = Int((i - 1) / 10) * 10
    swap = getRnd(Group + 10, Group + 1)
    tmp = AR(i)
    AR(i) = AR(swap)
    AR(swap) = tmp
Next i
End Sub

Sub fillOne(ByRef Pat As Object)
Set Pat = CreateObject("System.Collections.ArrayList")
For i = 1 To 18
    Select Case Rnd()
        Case Is < 0.333
            Pat.Add Array(1, 0, 0)
        Case Is < 0.666
            Pat.Add Array(0, 1, 0)
        Case Is < 1
            Pat.Add Array(0, 0, 1)
    End Select
Next i
End Sub

Sub fillTwo(ByRef Pat As Object)
Set Pat = CreateObject("System.Collections.ArrayList")
For j = 1 To 36
    Select Case Rnd()
        Case Is < 0.333
            Pat.Add Array(1, 1, 0)
        Case Is < 0.666
            Pat.Add Array(0, 1, 1)
        Case Is < 1
            Pat.Add Array(1, 0, 1)
    End Select
Next j
End Sub

Sub fillArray(ByRef Result() As Variant, Queue As Object, ByRef Ones As Object, Twos As Object, Patterns 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

For i = 1 To 9
    RN = getRnd(Patterns.Count - 1, 0)
    tmp = Patterns(RN)
    Patterns.removeat RN
    For j = 0 To UBound(tmp)
        If tmp(j) = 1 Then
            RP = getRnd(Ones.Count - 1, 0)
            Pat = Ones(RP)
            Ones.removeat RP
        Else
            RP = getRnd(Twos.Count - 1, 0)
            Pat = Twos(RP)
            Twos.removeat RP
        End If
        For k = LBound(Pat) To UBound(Pat)
            If Pat(k) = 1 Then
                Result(Pos) = Queue.dequeue()
            Else
                Result(Pos) = vbNullString
            End If
            Pos = Pos + 1
        Next k
    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


----------



## craigey1

lrobbo314 said:


> Small code revision.  This version seems to do the trick.



Thanks for all your work on this, but sorry to say - it seems that there's some lines with 6 numbers & the 10's (10, 20, 30, 40, 50 , 60, 70, 80) need to move over to the next column.


----------



## lrobbo314

Let's give this one a go.



		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 Ones As Object:             fillOne Ones
Dim Twos As Object:             fillTwo Twos
Dim Patterns As Object:         setPatterns Patterns
Dim Queue As Object

Shuffle AR
fillQueue Queue, AR
fillArray Result, Queue, Ones, Twos, Patterns
fillOutput Result, Output
Range("A1").Resize(UBound(Output, 1), UBound(Output, 2)).Value2 = Output
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 fillOne(ByRef Pat As Object)
Set Pat = CreateObject("System.Collections.ArrayList")
For i = 1 To 18
    Select Case Rnd()
        Case Is < 0.333
            Pat.Add Array(1, 0, 0)
        Case Is < 0.666
            Pat.Add Array(0, 1, 0)
        Case Is < 1
            Pat.Add Array(0, 0, 1)
    End Select
Next i
End Sub

Sub fillTwo(ByRef Pat As Object)
Set Pat = CreateObject("System.Collections.ArrayList")
For j = 1 To 36
    Select Case Rnd()
        Case Is < 0.333
            Pat.Add Array(1, 1, 0)
        Case Is < 0.666
            Pat.Add Array(0, 1, 1)
        Case Is < 1
            Pat.Add Array(1, 0, 1)
    End Select
Next j
End Sub

Sub fillArray(ByRef Result() As Variant, Queue As Object, ByRef Ones As Object, Twos As Object, Patterns 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

For i = 1 To 9
    tmp = Patterns(i - 1)
    For j = 0 To UBound(tmp)
        If tmp(j) = 1 Then
            RP = getRnd(Ones.Count - 1, 0)
            Pat = Ones(RP)
            Ones.removeat RP
        Else
            RP = getRnd(Twos.Count - 1, 0)
            Pat = Twos(RP)
            Twos.removeat RP
        End If
        For k = LBound(Pat) To UBound(Pat)
            If Pat(k) = 1 Then
                Result(Pos) = Queue.dequeue()
            Else
                Result(Pos) = vbNullString
            End If
            Pos = Pos + 1
        Next k
    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

Sub swap()
Dim c1 As Range, c2 As Range
Dim r As Range: Set r = Selection
Dim tmp As Integer
Set c1 = r.Areas(1).Cells(1)
Set c2 = r.Areas(2).Cells(1)
tmp = c1.Value2
c1.Value2 = c2.Value2
c2.Value2 = tmp
End Sub


----------



## craigey1

lrobbo314 said:


> Let's give this one a go.


I'm going to owe you drink (or a charity donation) if you can crack this!  
The numbers are in the right columns now, but still getting some rows with less than 5 numbers & others with more (had one with 8).  All rows need to have exactly 5 numbers.


----------



## lrobbo314

Got a good feeling about this one, lol.



		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

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
                Result(Pos) = Queue.dequeue()
            Else
                Result(Pos) = vbNullString
            End If
            Pos = Pos + 1
        Next k
    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


----------



## 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


----------



## craigey1

lrobbo314 said:


> Got a good feeling about this one, lol.



You sir are a genius.  That works perfectly.

I'm going to have to through the code & try to figure out what it's doing (I know a little vb - I can use arrays & loop through & use if / case statements etc, but no where near enough to follow what this is doing, yet).  
Is there anything I can do to thank you for your effort?  Can donate to a charity on your behalf or buy you a coffee / beer etc (hope that's not against the rules & wouldn't always do it, but you've spent a lot of time & effort coming up with this solution).

Thanks again.


----------



## lrobbo314

craigey1 said:


> You sir are a genius.  That works perfectly.
> 
> I'm going to have to through the code & try to figure out what it's doing (I know a little vb - I can use arrays & loop through & use if / case statements etc, but no where near enough to follow what this is doing, yet).
> Is there anything I can do to thank you for your effort?  Can donate to a charity on your behalf or buy you a coffee / beer etc (hope that's not against the rules & wouldn't always do it, but you've spent a lot of time & effort coming up with this solution).
> 
> Thanks again.



Thanks for the nice comments.  I appreciate the sentiment for a donation or a beer.  I started a youtube channel with Excel tutorials.  If you're interested in checking out those videos that would be awesome.

Either way, glad we got it sorted out.


----------



## lrobbo314

forgot the link, lol


----------



## Rick Rothstein

braindiesel said:


> braindiesel said:
> 
> 
> 
> Question...
> Is it possible that a cardhave a column with 3 numbers in it and anotehr columne has 0 numbers in it
> 
> 
> 
> 
> 
> 
> craigey1 said:
> 
> 
> 
> No - It'll have at least 1 number, but a maximum of 2.
> 
> Click to expand...
Click to expand...

Are you sure about the "maximum of 2" restriction? I ask because Wikipedia says this...

"*Strips of 6 tickets*
A typical bingo ticket contains 27 spaces, arranged in nine columns by three rows. Each row contains five numbers and four blank spaces. *Each column contains up to three numbers*..."

Here is the link for that citation... Bingo (British version) - Wikipedia


----------



## craigey1

Rick Rothstein said:


> Are you sure about the "maximum of 2" restriction? I ask because Wikipedia says this...
> 
> "*Strips of 6 tickets*
> A typical bingo ticket contains 27 spaces, arranged in nine columns by three rows. Each row contains five numbers and four blank spaces. *Each column contains up to three numbers*..."


It appears you are quite correct.  Sorry.  I was going from memory & the example ticket that I posted in the first post.  
Hmmm.  I'll have to have a play & see if I can figure this out (or just randomly change values until it looks right)!


----------



## Mcclane86

Hi there, did you manage to get this working in the end, I've been trying to find something similar that takes account of the 3 numbers per column rule. It would also be useful to know how to put a blank line between each game for formatting purposes. I wish my vba knowledge was up to scratch to be able to produce something like this.


----------



## lrobbo314

@tezza asked a question about this old post.

I noticed what Rick said about the, maximum of 2, in post #24.

So, I revisited it and this code seems to fill out the card with all the correct parameters in place.



		VBA Code:
__


Sub QMAIN()
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
End Sub

Sub NumPatterns(ByRef PAT As Object, Total As Integer)
Randomize
Dim r As Double:    r = Rnd
Set PAT = CreateObject("System.Collections.ArrayList")

Select Case Total
    Case 9
        If r < 0.5 Then
            PAT.Add Array(1, 1, 1)
            PAT.Add Array(1, 1, 0)
            PAT.Add Array(1, 0, 0)
            PAT.Add Array(1, 0, 0)
            PAT.Add Array(1, 0, 0)
            PAT.Add Array(1, 0, 0)
        Else
            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)
        End If
    Case 10
        If r < 0.5 Then
            PAT.Add Array(1, 1, 1)
            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)
        Else
            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)
        End If
    Case 11
        If r < 0.5 Then
            PAT.Add Array(1, 1, 1)
            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)
        Else
            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 If
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 COL As Integer:     COL = 1

For i = 1 To 9
    MatchPat COL, PAT, QUE, Output
    PAT.Clear
    COL = COL + 1
Next i
    
Range("A1").Resize(UBound(Output), UBound(Output, 2)).Value = Output
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

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()
    Next p
    
    RG = RG + 3
Loop

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


----------



## tezza

lrobbo314 said:


> @tezza asked a question about this old post.
> 
> I noticed what Rick said about the, maximum of 2, in post #24.
> 
> So, I revisited it and this code seems to fill out the card with all the correct parameters in place.
> 
> 
> 
> VBA Code:
> __
> 
> 
> Sub QMAIN()
> 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
> End Sub
> 
> Sub NumPatterns(ByRef PAT As Object, Total As Integer)
> Randomize
> Dim r As Double:    r = Rnd
> Set PAT = CreateObject("System.Collections.ArrayList")
> 
> Select Case Total
> Case 9
> If r < 0.5 Then
> PAT.Add Array(1, 1, 1)
> PAT.Add Array(1, 1, 0)
> PAT.Add Array(1, 0, 0)
> PAT.Add Array(1, 0, 0)
> PAT.Add Array(1, 0, 0)
> PAT.Add Array(1, 0, 0)
> Else
> 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)
> End If
> Case 10
> If r < 0.5 Then
> PAT.Add Array(1, 1, 1)
> 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)
> Else
> 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)
> End If
> Case 11
> If r < 0.5 Then
> PAT.Add Array(1, 1, 1)
> 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)
> Else
> 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 If
> 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 COL As Integer:     COL = 1
> 
> For i = 1 To 9
> MatchPat COL, PAT, QUE, Output
> PAT.Clear
> COL = COL + 1
> Next i
> 
> Range("A1").Resize(UBound(Output), UBound(Output, 2)).Value = Output
> 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
> 
> 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()
> Next p
> 
> RG = RG + 3
> Loop
> 
> 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


Thank you, I will try give this a go and let you know.


----------



## tezza

lrobbo314 said:


> @tezza asked a question about this old post.
> 
> I noticed what Rick said about the, maximum of 2, in post #24.
> 
> So, I revisited it and this code seems to fill out the card with all the correct parameters in place.
> 
> 
> 
> VBA Code:
> __
> 
> 
> Sub QMAIN()
> 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
> End Sub
> 
> Sub NumPatterns(ByRef PAT As Object, Total As Integer)
> Randomize
> Dim r As Double:    r = Rnd
> Set PAT = CreateObject("System.Collections.ArrayList")
> 
> Select Case Total
> Case 9
> If r < 0.5 Then
> PAT.Add Array(1, 1, 1)
> PAT.Add Array(1, 1, 0)
> PAT.Add Array(1, 0, 0)
> PAT.Add Array(1, 0, 0)
> PAT.Add Array(1, 0, 0)
> PAT.Add Array(1, 0, 0)
> Else
> 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)
> End If
> Case 10
> If r < 0.5 Then
> PAT.Add Array(1, 1, 1)
> 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)
> Else
> 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)
> End If
> Case 11
> If r < 0.5 Then
> PAT.Add Array(1, 1, 1)
> 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)
> Else
> 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 If
> 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 COL As Integer:     COL = 1
> 
> For i = 1 To 9
> MatchPat COL, PAT, QUE, Output
> PAT.Clear
> COL = COL + 1
> Next i
> 
> Range("A1").Resize(UBound(Output), UBound(Output, 2)).Value = Output
> 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
> 
> 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()
> Next p
> 
> RG = RG + 3
> Loop
> 
> 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


Hi, I just run this at home on Excel 2010 and it stopped here:





Maybe 2010 is too old so I will try in work this week, but whilst the home pc run the previous version ok, the works laptop failed. 

Thank you for revisiting this


----------



## lrobbo314

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



		VBA Code:
__


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


----------



## 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

lrobbo314 said:


> Nope, my fault.  Missed a function.  Paste the code in below the rest of the code and it should work.
> 
> 
> 
> VBA Code:
> __
> 
> 
> 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

lrobbo314 said:


> 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.xlsmABCDEFGHI111376078223943538136132759627982417255563855428304176683644678771031426485223854687086916295672881032485111314266575121535495277831318204657711411934588015924476673841612214061173345698918723507490Sheet3



		VBA Code:
__


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

lrobbo314 said:


> 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.xlsmABCDEFGHI111376078223943538136132759627982417255563855428304176683644678771031426485223854687086916295672881032485111314266575121535495277831318204657711411934588015924476673841612214061173345698918723507490Sheet3
> 
> 
> 
> VBA Code:
> __
> 
> 
> 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 BINGOABCDEFGHIJKL11273141745422839455761543615667781544316205387545730657588546183743596854711365060765481221446783549823385485541022405262725411426495684541251935738954131325477082541429335564865415914485878541623263718054171034426990541817244651795419209101010101010101121988888887222311020304050607080242112131415161718125312223242526272822641323334353637383275142434445464748428615253545556575852971626364656667686308172737475767778731918283848586878883219293949596979893390Sheet1Cell FormulasRangeFormulaK1:K18K1=COUNTA(A1:I1)L1:L18L1=COUNTBLANK(A1:I1)A20:I20A20=COUNTA(A1:A18)A21:I21A21=COUNTBLANK(A1:A18)A23:A31,I23:I33,B23:H32A23=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


----------



## 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

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 BINGOABCDEFGHIJKL11273141745422839455761543615667781544316205387545730657588546183743596854711365060765481221446783549823385485541022405262725411426495684541251935738954131325477082541429335564865415914485878541623263718054171034426990541817244651795419209101010101010101121988888887222311020304050607080242112131415161718125312223242526272822641323334353637383275142434445464748428615253545556575852971626364656667686308172737475767778731918283848586878883219293949596979893390Sheet1Cell FormulasRangeFormulaK1:K18K1=COUNTA(A1:I1)L1:L18L1=COUNTBLANK(A1:I1)A20:I20A20=COUNTA(A1:A18)A21:I21A21=COUNTBLANK(A1:A18)A23:A31,I23:I33,B23:H32A23=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

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

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

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

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

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

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.xlsmBCDEFGHIJKL21021364871CARD 13113556387432659677351720314477CARD 26446536180751257648381827427585CARD 39193256788610234475865111133517081CARD 412824496976131429305482142537405074CARD 51562838668816715436890172235417284CARD 618233960798919916455262Bingo



		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

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

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

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


----------



## 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


----------



## lrobbo314

Think I was trying to be too clever with this subroutine.  I updated and haven't ran into the problem again.



		VBA Code:
__


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


----------



## craigey1

lrobbo314 said:


> Think I was trying to be too clever with this subroutine.  I updated and haven't ran into the problem again.


Fantastic, that seems to have fixed it for me.  Thanks again, for all your time & effort.


----------



## baldheadedscott

craigey1 said:


> Fantastic, that seems to have fixed it for me.  Thanks again, for all your time & effort.


Do you have the file for this still? been trying to figure it out, and I just can't get it...


----------



## tezza

baldheadedscott said:


> Do you have the file for this still? been trying to figure it out, and I just can't get it...


I haven't updated mine with the latest code but if you want a head start, here's a dropbox link to the one I'm using.

*Bingo in Dropbox*

It's been a while since I've used Dropbox so any issues let me know.

This runs fine on 2010 and 2016 Excel version.

Thanks to @lrobbo314 for the code, I'd have never got it running otherwise


----------



## lrobbo314

Thanks @tezza.

I made a playable javascript version as well.  CSS isn't my strong suit, but I'm happy with how it came out.  Optimized the swap algorithm a bit too.

Here is the link if anyone is interested.

p5.js Web Editor

Also, here is a link to an Excel workbook that has the code and everything.

UK Bingo No OBJ DB.xlsm


----------



## tezza

lrobbo314 said:


> I made a playable javascript version as well.  CSS isn't my strong suit, but I'm happy with how it came out.  Optimized the swap algorithm a bit too.


That's taking it to another level lol, I've never touch on CSS.


----------



## lrobbo314

Don't know if anyone here saw it, but I also made an excel formula to generate US bingo cards.  Can't imagine doing this for UK Bingo with formulas. Should be possible since Excel is now considered to be Turing complete with dynamic array formulas, but F me, no way!

Anyway, here's the link. US Bingo Formula


----------



## baldheadedscott

lrobbo314 said:


> Thanks @tezza.
> 
> I made a playable javascript version as well.  CSS isn't my strong suit, but I'm happy with how it came out.  Optimized the swap algorithm a bit too.
> 
> Here is the link if anyone is interested.
> 
> p5.js Web Editor
> 
> Also, here is a link to an Excel workbook that has the code and everything.
> 
> UK Bingo No OBJ DB.xlsm


Okay, excuse my ignorance, but I don't know how or what to do to randomize the cards so that the next set/card is di=fferent than the one that shows up initially.
I made my own regular/US bingo cards, and I know how to do it on mine. But I can't seem to figure out how to do that with yours? Not sure if it's because of the macros or what?


----------



## tezza

baldheadedscott said:


> Okay, excuse my ignorance, but I don't know how or what to do to randomize the cards so that the next set/card is di=fferent than the one that shows up initially.
> I made my own regular/US bingo cards, and I know how to do it on mine. But I can't seem to figure out how to do that with yours? Not sure if it's because of the macros or what?


Enable macros and click New Books. That will run the macro to create new numbers in the tabs Book 1 to Book 10

The game tab just combines them all.

To run the code in your own workbook, go to a blank sheet and run the macro and it'll generate the numbers there for you.  Each time you run the macro it will overwrite the old ones.


----------



## tezza

baldheadedscott said:


> Okay, excuse my ignorance, but I don't know how or what to do to randomize the cards so that the next set/card is di=fferent than the one that shows up initially.
> I made my own regular/US bingo cards, and I know how to do it on mine. But I can't seem to figure out how to do that with yours? Not sure if it's because of the macros or what?


I uploaded a quick video to dropbox to give you an idea of what I do.

Bingo vid in dropbox

The first tab picks the random numbers

The Game is for auto play mode, when the first tab generates a random number, it shows on all the games in the Game tab

The first tab also tracks at the bottom all of the games and will also show you when a line or house has been achieved.

For a fresh restart hit New Books, New Game then Next Number until there's a winner.

Can it be done better?  More than likely but this is my limitations.


----------

