UK Bingo cards

C

craigey1

New Member
Joined
Apr 6, 2020
Messages
30
Office Version
  1. 2019
Platform
  1. Windows
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

jumbobingoticket-jpg.10662
 

Attachments

  • JumboBingoTicket.jpg
    JumboBingoTicket.jpg
    119 KB · Views: 3,418
Sort by date Sort by votes
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
 
Upvote 0

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
@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
Click to expand...
 
Upvote 0
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

jumbobingoticket-jpg.10662
Click to expand...
Check the below link from Chandoo.org

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 chandoo.org
 
Upvote 0
Peter_SSs said:
@lrobbo314
It appears to me that your codes do not take account of this requirement?
Click to expand...

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.
 
Upvote 0
Small code revision. This version seems to do the trick.

20200407 MXL Bingo.xlsm
ABCDEFGHIJ
110446585Card 1
21624425562
361323367289
42237496387Card 2
591133516673
63435471
7207783Card 3
873546606479
922840455681
101827677682Card 4
1117293250537086
1243459
131238587488Card 5
14530394861
151425526878
16121577584Card 6
17192631476980
188154190
Sheet2


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
 
Upvote 0
lrobbo314 said:
Small code revision. This version seems to do the trick.
Click to expand...

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.
 
Upvote 0
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
 
Upvote 0
lrobbo314 said:
Let's give this one a go.
Click to expand...
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.
 
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Creating a random sequence of items from a weighted list with no duplicates
Replies
6
Views
115
shg
shg
M
  • Question Question
Spot It or Dobble
Replies
2
Views
400
ManUBlueJay
M
K
  • Question Question
Bingo Board Formula
Replies
5
Views
590
KiwiNan
K
B
  • Question Question
Simulator for one event in blackjack game
Replies
2
Views
381
baha17
B
G
  • Question Question
Predict Blackjack cards?
2
Replies
10
Views
1K
Joe4
Joe4

Forum statistics

Threads
1,223,246
Messages
6,170,999
Members
452,373
Latest member
TimReeks

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top