Excelのこととか色々

Excel のこととか楽天とか いろいろ書いてみます・・・

トップ > Excel > 【Excel でビンゴゲームを作る２】

【Excel でビンゴゲームを作る２】

Excel VBA マクロ リボン 初心者英語 効率化 ツール ゲーム

【ビンゴゲームを作る】

　 

　　Excelでビンゴゲーム作ってみた

 

**************************************************

Excel で ビンゴゲーム作ってみました。

今回はフォームではなく、シート上で作りました。

Bingoゲーム作りました



残りのマクロです。

 

 

マクロ

抽選ボタン

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

'カウントが５になったら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　'Bingo２の列は10-14（J-N列）
　　　　　　　Range("J8") = "BINGO"
　　　　　　ElseIf c > 17 And c < 23 Then　'Bingo３ の列は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　（なので＋８）
　　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

 

*************************************************

だらだらと長くなってしまいます・・・

もっと短く効率的な書き方ができるよう勉強せねば・・・ 

 

 

 

／＿／＿／＿／＿／＿／＿／＿／＿／＿／＿／＿／＿／＿／＿

 

個人用マクロブックについてはこちら

www.tuna-kichi.com

 

リボンに登録についてはこちら

www.tuna-kichi.com

 

＿／＿／＿／＿／＿／＿／＿／＿／＿／＿／＿／＿／＿／＿／＿／＿／