ExcelVBAで、ビンゴツールを作った。 - bimori466のエクセルブログ

f:id:bimori466:20211121100014p:plain

忘年会で幹事やります(´;ω;｀)

2021年年末、コロナが落ち着いているとはいえ、まだ対面での忘年会はやりにくいですね。なので、Zoom会です。
忘年会で幹事をやることになりました。忘年会の定番イベントとして「ビンゴ大会」をやるのは会社の定番ではないでしょうか。
んで、ビンゴやるにあたってネットで無料ツール探すのですが、機能としては番号出すだけのものが多い印象でした。つまり確認作業はアナログです。
聞くところによると、Zoom会でビンゴをやって2時間かかったそうです(;^ω^)
これ聞いて、時間の無駄やろ！というのが私の感想です。なので、ビンゴツールを作りました。作成期間は、１日です。

目次
　１　閲覧対象者
　２　得られる効果
　３　設計
　４　コードの解説　
　５　備考　
　６　感想
　７　noteで無料DL

１　閲覧対象者

Zoom会等、画面共有できる環境でビンゴ大会をやる人。
デザインより時間効率を優先する人。

２　得られる効果

ビンゴ大会の時間短縮。
出目の確認、ビンゴ者の判断を自動化。
ネットに転がっているビンゴツールは３０人以上だと有料になったり、ブラウザのセッションを切ると別のビンゴカードが作成されて管理しずらいので、その辺の制限からの開放。

３　設計

f:id:bimori466:20211121100938p:plain

使うSheetは上の画像の通り、４Sheetです。

１　Sheet1　　　　ビンゴカード作成用のテンプレートです。
２　参加者Sheet　　参加者を列Aに書き込みます。参加者の分Sheetを作成します。
３　回すSheet　　　出目を出します。また、出た出目を転記します。
４　景品Sheet　　　景品を書き込みます。このSheetには特に何もしません。景品を書いて誰が当たったのか転記するのはマニュアルです。

（注）参加者の人数分Sheetを作成するので、人数制限としては作成できるSheet数となります。PCのメモリに依存しますが、100人くらいは余裕だと思います。

仕様

参加者の数だけ、ビンゴカード（Sheet）を作ります。また、PDFで保存します。
（作成したビンゴカードPDFは、ZoomのチャットにUPして各人に開いてもらいます。）

f:id:bimori466:20211121101816p:plain

上の画像が、回すSheetです。こいつがメインのSheetです。
出目を出すをクリックします。赤色のセルに乱数で出目を出します。出た出目は、薄い緑のセルに転記します。端の右下が黒いのは１～９９までの数字を使うからです。
出目を出したら、各人のビンゴカードに該当するかチェックします。該当すれば、セルを黄色に塗ります。
その後、ビンゴ者がいるかチェックします。
最後に、メッセージで誰のマスが開いたのか、誰がビンゴになったのかを出します。

イメージ

ビンゴ開始↓↓
f:id:bimori466:20211121102640p:plain

参加者5名のシートができていますね。

参加者のSheet↓↓
f:id:bimori466:20211121102738p:plain

出目を出すをクリック↓↓
f:id:bimori466:20211121102852p:plain

赤色のセルに出目が出ます。また誰が当たったのかをメッセージで知らせてくれます。

f:id:bimori466:20211121103138p:plain

参加者３のSheetの8番セルが黄色に塗りつぶされています。

ビンゴを通知（ここではいじってます(;^ω^)）↓↓
f:id:bimori466:20211121103631p:plain

４　コードの解説

まず、ビンゴカードを作ります。
以下のコードをご覧ください。

１　ビンゴカード作成する「make_bingoCD」

Sub make_bingoCD()
    
    Dim arrUnique
    Dim cr As Range
    Dim shName
    Dim i, j, e
    Dim sh_participant As Worksheet: Set sh_participant = Worksheets("参加者")
    Dim cenCnt, arrIX
    Dim wrNo
    Dim noFlg As Boolean
    Dim filePath
    
    Application.ScreenUpdating = False
    
    Randomize
    
    '名前の数だけSheetを作成してカードを作る
    For i = 1 To sh_participant.Cells(Rows.Count, 1).End(xlUp).Row
        shName = "CD_" & sh_participant.Cells(i, 1)
        
        Worksheets("Sheet1").Copy after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = shName
        
        Set cr = Range("B3:F7")
        arrUnique = Array()
        cenCnt = 0: arrIX = 0
        
        
        '乱数を代入処理
        For Each e In cr
            cenCnt = cenCnt + 1
            
            If cenCnt = 13 Then
                'pass
            Else
                wrNo = Int(Rnd * 100)
                
                If LBound(arrUnique) = 0 Then
                    
                    '１回目が0の場合、0以外なるまで作成。
                    If wrNo = 0 Then
                        Do
                            wrNo = Int(Rnd * 100)
                        Loop Until wrNo <> 0
                    End If
                    
                    arrIX = arrIX + 1
                    ReDim arrUnique(1 To arrIX)
                    arrUnique(arrIX) = wrNo
                    e.Value = wrNo
                Else
                    Do Until noFlg = True
                        For j = LBound(arrUnique) To UBound(arrUnique)
                            If wrNo = arrUnique(j) Or wrNo = 0 Then
                                wrNo = Int(Rnd * 100)   '乱数の作成
                                j = 1
                                Exit For
                            End If
                            
                            If wrNo <> arrUnique(j) Then
                                If j = UBound(arrUnique) Then
                                    arrIX = arrIX + 1
                                    ReDim Preserve arrUnique(1 To arrIX)
                                    arrUnique(arrIX) = wrNo
                                    e.Value = wrNo
                                    noFlg = True
                                    Exit For
                                End If
                            End If
                        Next
                    Loop
                    
                    noFlg = False
                    
                End If
            End If
        Next
        
        'PDFで保存
        filePath = ThisWorkbook.Path & "\" & sh_participant.Cells(i, 1) & "さん_BINGOカード"
        
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        filePath, Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
        
    Next
    
    Worksheets("回す").Select
    
End Sub

必要な仕様としては、乱数で番号が被ってはいけません。なので、出目を変数arrUniqueに記憶します。出目の変数wrNoと被って無ければSheetに書き込みます。その後PDFを作成する（配布用）。
この処理を、参加者人数分処理します。

では、ビンゴカードができたところでビンゴ開始です。出目を出すコードを見ていきましょう。

２　出目を出し、該当番号、ビンゴ者のチェック「出目」

Sub 出目()
    
    Dim sh As Worksheet: Set sh = Worksheets("回す")
    Dim arrNo, arrRng As Range
    Dim roll
    Dim i, j, e
    Dim noFlg As Boolean, noFlg2 As Boolean
    Dim che_sh
    Dim che_cr
    Dim tgt_cr As Range
    Dim strFindRoll
    Dim strReach
    Dim strBINGO
    Dim bingo_cr
    
    
    Randomize
    roll = Int(Rnd * 100)
    
    sh.Range("C4") = ""
    
    arrNo = sh.Range("J2:S12")
    Set arrRng = sh.Range("J2:S12")
    
    '重複しない出目を決定。
    Do Until noFlg = True
        
        If sh.Range("R11") <> "" Then MsgBox "1～99のすべての数値が出力されました。": Exit Sub
        
        For i = LBound(arrNo) To UBound(arrNo)
            For j = LBound(arrNo, 2) To UBound(arrNo, 2)
                If roll = arrNo(i, j) Or roll = 0 Then
                    roll = Int(Rnd * 100)   '乱数の作成
                    i = 1
                    j = 1
                    noFlg2 = True
                    Exit For
                End If
                
                If roll <> arrNo(i, j) Then
                    If i = UBound(arrNo) And j = UBound(arrNo, 2) Then
                        For Each e In arrRng
                            If e = "" Then
                                'Call ドラムロール音
                                'Application.Wait (Now + TimeValue("00:00:06"))
                                sh.Range("C4") = roll
                                e.Value = roll
                                Exit For
                            End If
                        Next
                        
                        noFlg = True
                        Exit For
                    End If
                End If
            Next
            
            If noFlg2 = True Then Exit For
        Next
        
        If noFlg2 = True Then noFlg2 = False
    Loop
    
    
    '出目に対する各Sheetのチェック処理
    For Each che_sh In Worksheets
        If che_sh.Name Like "CD*" Then
            Set tgt_cr = che_sh.Range("B3:F7")
            For Each che_cr In tgt_cr
                If che_cr = roll Then
                    che_cr.Interior.ColorIndex = 6  'セルを黄色に塗る
                    '当たった人の名前
                    If strFindRoll = "" Then
                        strFindRoll = roll & "番で" & vbCrLf & Replace(che_sh.Name, "CD_", "") & "さんのマスが開きました"
                    Else
                        strFindRoll = strFindRoll & vbCrLf & Replace(che_sh.Name, "CD_", "") & "さんのマスが開きました"
                    End If
                    
                    Exit For
                End If
            Next
        End If
    Next
    
    '再計算
    Application.Calculation = xlCalculationAutomatic
    Application.Calculate
    
    'ビンゴになった人、出目が当たった人を表示
    For Each che_sh In Worksheets
        If che_sh.Name Like "CD*" Then
            
            '斜めのビンゴを求める
            che_sh.Range("H2") = CHeck_Bingo(che_sh.Range("B3,C4,D5,E6,F7")) '右下
            che_sh.Range("H8") = CHeck_Bingo(che_sh.Range("B7,C6,D5,E4,F3")) '右上
            
            '縦ビンゴを求める
            che_sh.Range("B9") = CHeck_Bingo(che_sh.Range("B3:B7"))
            che_sh.Range("C9") = CHeck_Bingo(che_sh.Range("C3:C7"))
            che_sh.Range("D9") = CHeck_Bingo(che_sh.Range("D3:D7"))
            che_sh.Range("E9") = CHeck_Bingo(che_sh.Range("E3:E7"))
            che_sh.Range("F9") = CHeck_Bingo(che_sh.Range("F3:F7"))
            
            '横ビンゴを求める
            che_sh.Range("H3") = CHeck_Bingo(che_sh.Range("B3:F3"))
            che_sh.Range("H4") = CHeck_Bingo(che_sh.Range("B4:F4"))
            che_sh.Range("H5") = CHeck_Bingo(che_sh.Range("B5:F5"))
            che_sh.Range("H6") = CHeck_Bingo(che_sh.Range("B6:F6"))
            che_sh.Range("H7") = CHeck_Bingo(che_sh.Range("B7:F7"))
            
            Set bingo_cr = che_sh.Range("B9:F9, H2:H8")
            
            For Each e In bingo_cr
                
                'リーチの表示
                If e.Value = 26 Then
                    If strReach = "" Then
                        strReach = Replace(che_sh.Name, "CD_", "") & "さん、リーチ！"
                    Else
                        strReach = strReach & vbCrLf & Replace(che_sh.Name, "CD_", "") & "さん、リーチ！"
                    End If
                    
                End If
                
                
                If e.Value = 30 Then
                    'ビンゴの表示
                    If strBINGO = "" Then
                        strBINGO = roll & "番で" & vbCrLf & Replace(che_sh.Name, "CD_", "") & "さん、BINGO！"
                    Else
                        strBINGO = strBINGO & vbCrLf & Replace(che_sh.Name, "CD_", "") & "さん、BINGO！"
                    End If
                    
                    'Sheet名を"済"を加える。
                    che_sh.Name = "済_" & che_sh.Name
                    Exit For
                End If
            Next
        End If
    Next
    
    
    'メッセージ表示
    If strFindRoll <> "" Then
        Call マスが開く音
        Application.Wait (Now + TimeValue("00:00:01"))
        MsgBox strFindRoll
    End If
    
    If strReach <> "" Then
        Call リーチ音
        Application.Wait (Now + TimeValue("00:00:01"))
        MsgBox strReach
    End If
    
    
    If strBINGO <> "" Then
        Call ビンゴ音
        Application.Wait (Now + TimeValue("00:00:01"))
        Call 歓声音
        MsgBox strBINGO
    End If
        
    
    
End Sub

ここでも、重複の出目はダメです。回すSheetのRange("J2:S12")を変数arrNoに代入して、重複した場合、乱数を取り直します（変数roll）。
晴れて重複してない、乱数が取得できたら、回すSheetの薄い緑に転記します。その後、各個人Sheetに該当の番号があるかチェックします。
当たった人の該当セルを黄色で塗りつぶします。
また、リーチの人がいたらMsgboxでお知らせする。BINGOの人がいたら、Msgboxでお知らせします。
次に、ビンゴ者のチェックをします。これには以下のFunctionを使います。

Function CHeck_Bingo(tgt_cells As Range)
    
    Dim myRng
    Dim colorNo: colorNo = 0
    
    For Each myRng In tgt_cells
        colorNo = colorNo + myRng.Interior.ColorIndex ' 背景色
    Next
    
    CHeck_Bingo = colorNo
    
End Function

要は、縦、横、斜めの塗りつぶされた色の合計が30であればビンゴです。

メッセージ用の変数strFindRoll、strBINGOが空白でなければメッセージを表示します。
ちなみに、ビンゴになった人のSheet名は頭に「済_」を付けるので、ビンゴになった後は、出目のチェック対象にはなりません。

こんなところです。

５　備考

ビンゴカードのSheetをすべて削除したい場合は以下のマクロを実行します。

Sub Sheet_Delete()
    
    Dim sh As Worksheet
    Dim e
    
    Application.DisplayAlerts = False
    For Each e In Worksheets
        If e.Name Like "*CD_*" Then e.Delete
    Next
    
End Sub

これでカードを作り直すのが簡単たんです。
PDFはマニュアルでけしてくださいm(_ _"m)

６　感想

乱数を2回作っているコード部分を不思議に思った人もいるかもしれません。この理由は、乱数の１回目がほぼ１００％「７０」になるんです(;^ω^)
仕様なのかはわかりませんが、気になったので２回乱数を取っています。
このくらいのお遊びツールを作れるエクセルVBAは素晴らしいですね。

追記

乱数の１回目がほぼ１００％「７０」になる理由は、Randomizeで「乱数テーブル」を初期化していなかったためとのご指摘いただきました。
コードにも反映しております。

７　noteで無料DL

以下のリンクから、noteで無料DLできます。

note.com

忘年会で幹事やります(´;ω;｀)

１ 閲覧対象者

２ 得られる効果

３ 設計

仕様

イメージ

４ コードの解説

１ ビンゴカード作成する「make_bingoCD」

２ 出目を出し、該当番号、ビンゴ者のチェック「出目」

５ 備考

６ 感想

追記

７ noteで無料DL