【ビンゴゲームを作る】
**************************************************
Excel で ビンゴゲーム作ってみました。
今回はフォームではなく、シート上で作りました。
残りのマクロです。
マクロ
抽選ボタン
Sub BingoGame()
Dim WinNumber As Long '抽選で出た数字を格納します
Dim LastR As Long '最終行を格納
Dim i As Long
'チェックマークが1つ以上入っているか確認
'1つも入っていなければ、いったん抜ける
If Range("H1") = False And Range("P1") = False And Range("X1") = False Then
MsgBox "チェックが入っていません"
Exit Sub
End If
'各フィールドを定義する
Set Bingo1Range = Range(Cells(2, 2), Cells(6, 6))
Set Bingo2Range = Range(Cells(2, 10), Cells(6, 14))
Set Bingo3Range = Range(Cells(2, 18), Cells(6, 22))
'番号抽選
Do
WinNumber = Int(Rnd * 50) + 1
LastR = Cells(Rows.Count, 5).End(xlUp).Row '最終行を取得
'セルE9から下に今までに出た番号を累積していきます
'その中と同じ番号が重複していないかチェックします
If Range(Cells(10, 5), Cells(LastR, 5)).Find(WinNumber) Is Nothing Then
Cells(LastR + 1, 5) = Range("E9")
Range("E9") = WinNumber '重複していなければ番号確定します
Exit Do
End If
Loop
'*** Bingo1 *********************
'抽選で出た数字がカード上に見つかったら指定の背景色を付ける
If Range("H1") = True Then 'チェックマークのリンクするセルです
If Bingo1Range.Find(WinNumber) Is Nothing Then '見つからなければ何もしない
Else
Bingo1Range.Find(WinNumber).Interior.Color = RGB(255, 217, 102)
End If
End If
'*** Bingo2 *********************
If Range("P1") = True Then 'チェックマークのリンクするセルです
If Bingo2Range.Find(WinNumber) Is Nothing Then
Else
Bingo2Range.Find(WinNumber).Interior.Color = RGB(255, 217, 102)
End If
End If
'*** Bingo3 *********************
If Range("X1") = True Then 'チェックマークのリンクするセルです
If Bingo3Range.Find(WinNumber) Is Nothing Then
Else
Bingo3Range.Find(WinNumber).Interior.Color = RGB(255, 217, 102)
End If
End If
Call Judge 'Bingoかどうかチェックする
End Sub
Bingo 判定
Sub Judge()
Dim r As Long
Dim c As Long
Dim i As Long
Dim cnt As Long
'*** ヨコチェック*****
'*** Bingo1 *********************
For r = 2 To 6
cnt = 0
For c = 2 To 6
'背景色が指定の色だったら、カウントする
If Cells(r, c).Interior.Color = RGB(255, 217, 102) Then
cnt = cnt + 1
'カウントが5になったらBingoと表示する
If cnt = 5 Then
Range("B8") = "BINGO"
End If
End If
Next c
'*** Bingo2 *********************
cnt = 0
For c = 10 To 14
If Cells(r, c).Interior.Color = RGB(255, 217, 102) Then
cnt = cnt + 1
If cnt = 5 Then
Range("J8") = "BINGO"
End If
End If
Next c
'*** Bingo3 *********************
cnt = 0
For c = 18 To 22
If Cells(r, c).Interior.Color = RGB(255, 217, 102) Then
cnt = cnt + 1
If cnt = 5 Then
Range("R8") = "BINGO"
End If
End If
Next c
Next r
'*** タテチェック*****
'*** Bingo1 *********************
For c = 2 To 22
cnt = 0
For r = 2 To 6
If Cells(r, c).Interior.Color = RGB(255, 217, 102) Then
cnt = cnt + 1
If cnt = 5 Then
If c < 7 Then 'Bingo1 の列は2-6(B-F列)
Range("B8") = "BINGO"
ElseIf c > 9 And c < 15 Then 'Bingo2の列は10-14(J-N列)
Range("J8") = "BINGO"
ElseIf c > 17 And c < 23 Then 'Bingo3 の列は18-22(R-V列)
Range("R8") = "BINGO"
End If
End If
End If
Next r
Next c
'ナナメチェック
'左上から右下
'** Bingo1 *********************
cnt = 0
For r = 2 To 6
If Cells(r, r).Interior.Color = RGB(255, 217, 102) Then
cnt = cnt + 1
If cnt = 5 Then
Range("B8") = "BINGO"
End If
End If
Next r
'** Bingo2 *********************
cnt = 0
For r = 2 To 6
'Bingo2の最初の列は10 (なので+8)
If Cells(r, r + 8).Interior.Color = RGB(255, 217, 102) Then
cnt = cnt + 1
If cnt = 5 Then
Range("J8") = "BINGO"
End If
End If
Next r
'** Bingo3 *********************
cnt = 0
For r = 2 To 6
'Bingo2の最初の列は18 (なので+16)
If Cells(r, r + 16).Interior.Color = RGB(255, 217, 102) Then
cnt = cnt + 1
If cnt = 5 Then
Range("R8") = "BINGO"
End If
End If
Next r
'ナナメチェック
'右上から左下
'** Bingo1 *********************
cnt = 0
For r = 2 To 6
If Cells(r, r + 8).Interior.Color = RGB(255, 217, 102) Then
cnt = cnt + 1
If cnt = 5 Then
Range("B8") = "BINGO"
End If
End If
Next r
'** Bingo2 *********************
cnt = 0
For r = 2 To 6
If Cells(r, r + 8).Interior.Color = RGB(255, 217, 102) Then
cnt = cnt + 1
If cnt = 5 Then
Range("J8") = "BINGO"
End If
End If
Next r
'** Bingo3 *********************
cnt = 0
For r = 2 To 6
If Cells(r, r + 16).Interior.Color = RGB(255, 217, 102) Then
cnt = cnt + 1
If cnt = 5 Then
Range("R8") = "BINGO"
End If
End If
Next r
End Sub
リセットのマクロは前回書いたのですが、一部修正しました。
赤字箇所です。
リセット
Sub Reset()
Dim LastR As Long
Set Bingo1Range = Range(Cells(2, 2), Cells(6, 6))
Set Bingo2Range = Range(Cells(2, 10), Cells(6, 14))
Set Bingo3Range = Range(Cells(2, 18), Cells(6, 22))
'カード上の全てのセル背景色を塗りつぶし無しにします
Bingo1Range.Interior.ColorIndex = xlAutomatic
Bingo2Range.Interior.ColorIndex = xlAutomatic
Bingo3Range.Interior.ColorIndex = xlAutomatic
'中央の「Free」のセルに指定の色を付けます
Range("D4").Interior.Color = RGB(255, 217, 102)
Range("L4").Interior.Color = RGB(255, 217, 102)
Range("T4").Interior.Color = RGB(255, 217, 102)
'抽選で出た数字、「Bingo」の文字を削除します
LastR = Cells(Rows.Count, 5).Row
Range(Cells(9, 5), Cells(LastR, 5)) = ""
Range("B8") = ""
Range("J8") = ""
Range("R8") = ""
End Sub
*************************************************
だらだらと長くなってしまいます・・・
もっと短く効率的な書き方ができるよう勉強せねば・・・
/_/_/_/_/_/_/_/_/_/_/_/_/_/_
個人用マクロブックについてはこちら
リボンに登録についてはこちら
_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/