Excelのこととか色々

マクロをどんな Excel ファイルにも実行できるように設定して、3秒かかる操作も1秒で完了。あといろいろ書いてみます・・・

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

【ビンゴゲームを作る】

  

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

 

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

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

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

 

外観

ビンゴゲーム外観

最初は一つだけ作りましたが、

「ビンゴは一人でやるもんじゃないな」と思ったので、3つしました。 

 

各カードにチェックボックスのみを配置して1枚でも遊べるようにしました。

チェックボックスに文字は入れず、チェックボックスのみ使用しています。

チェックボックスに記述した文字列は大きさを変更できないので。

 

 

マクロ

今回は、特に説明することもないので、

えいっ!

丸投げだ!!

  ・

  ・

  ・ 

 

 

と思ったのですが、やっぱりいつも通り分けます。

 

                   

モジュールレベル変数

Dim Bingo1Range As Range  'Bingo1のカードのエリア
Dim Bingo2Range As Range  'Bingo2のカードのエリア
Dim Bingo3Range As Range  'Bingo3のカードのエリア
                   

カードの番号初期化

Sub InitializeField()
 '各シートの数字を初期化します
 Dim r As Long  '行番号を格納します
 Dim c As Long  '列番号を格納します
 Dim BingoNum 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))

 Call Reset  'リセットのプロシージャを呼び出します

'*** Bingo1 のカードの数字を設定します*********************
 If Range("H1") = True Then  'Bingo1のチェックマークが入っていたら
  For r = 2 To 6
   For c = 2 To 6
    Do  'カード上に入力する数字を重複しないよう設定します
     BingoNum = Int(Rnd * 50) + 1  '1-50の乱数を発生させます
     If c = 4 And r = 4 Then  '中央のフリーは無視します
      Exit Do
     End If

     '出た数字がカード上に既にあるかチェックする
     If Bingo1Range.Find(BingoNum) Is Nothing Then
      Cells(r, c) = BingoNum  '無ければ入力する
      Exit Do
     End If
    Loop
   Next c
  Next r
 End If

'*** Bingo2 *********************
 If Range("P1") = True Then
  For r = 2 To 6
   For c = 10 To 14
    Do 
     BingoNum = Int(Rnd * 50) + 1
     If c = 12 And r = 4 Then
      Exit Do
     End If
 
     If Bingo2Range.Find(BingoNum) Is Nothing Then
      Cells(r, c) = BingoNum
      Exit Do
     End If
    Loop
   Next c
  Next r
 End If

'*** Bingo3 *********************

 If Range("X1") = True Then
  For r = 2 To 6
   For c = 18 To 22
    Do
     BingoNum = Int(Rnd * 50) + 1
     If c = 20 And r = 4 Then
      Exit Do
     End If

     If Bingo3Range.Find(BingoNum) Is Nothing Then
      Cells(r, c) = BingoNum
      Exit Do
     End If
    Loop
   Next c
  Next r
 End If

End Sub

 

リセット

Sub Reset()
 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」の文字を削除します
 Range("E9") = ""
 Range("B8") = ""
 Range("J8") = ""
 Range("R8") = ""

End Sub

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

 

うーん・・・

もしかしたら、Range と For Each を使えば、もっと簡単にかけたのかなぁ・・・

調べてみよう。

 

こういうとこが、まだまだ初心者なんでしょうねぇ。

 

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

 

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

www.tuna-kichi.com

 

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

www.tuna-kichi.com

 

 

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

にほんブログ村 子育てブログ 幼稚園児育児へ にほんブログ村 英語ブログ 初心者英語へ にほんブログ村 IT技術ブログ VBAへ
 

  Graspyで無料プログラミング講座を受講する

 

==================================