Excelのこととか色々

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

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

【ビンゴゲームを作る】

  

  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

'カウントが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

 

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

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

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

 

 

 

/_/_/_/_/_/_/_/_/_/_/_/_/_/_

 

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

www.tuna-kichi.com

 

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

www.tuna-kichi.com

 

_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/