[[20101023215523]]　『ビンゴの判定について（VBA)』（はこまる）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『ビンゴの判定について（VBA)』（はこまる）

 Private Sub CommandButton2_Click()
 Dim i As Integer
 Dim j As Integer
 Dim k As Integer
 Dim 数字() As Long
 Dim 乱数(75) As Long
 Dim 比較用(75) As Integer
 Dim z As String
 Dim b As Variant

 '乱数を発生させる
 Randomize
    For i = 1 To 75
        Do
        乱数(i) = Int(Rnd() * 75 + 1)
        If Not 比較用(乱数(i)) = 1 Then
        比較用(乱数(i)) = 1
        Exit Do
        Else
        End If
        Loop
    Next

 '○回目のところの数字
 For j = 1 To 75
 Cells(2, 8) = j
 Range("h3:j5") = 乱数(j)

 '記録表
    If j <= 15 Then
    Cells(10, j + 1) = 乱数(j)
    ElseIf j <= 30 Then
    Cells(12, j - 14) = 乱数(j)
    ElseIf j <= 45 Then
    Cells(14, j - 29) = 乱数(j)
    ElseIf j <= 60 Then
    Cells(16, j - 44) = 乱数(j)
    ElseIf j <= 75 Then
    Cells(18, j - 59) = 乱数(j)
    End If

 '同じ番号に色を付ける
 z = Cells(6, 8)
 If z <> "" Then
 With Range(z).Interior
 .ColorIndex = 7
 End With
 End If
 z = Cells(6, 9)
 If z <> "" Then
 With Range(z).Interior
 .ColorIndex = 7
 End With
 End If

 '次の番号を出すか終わらせるかを問う質問
 If MsgBox(乱数(j) & "番です。" & vbCrLf & _
 "終了する時はキャンセルを押してください。" _
 , vbOKCancel, j & "回目") = vbCancel Then End:

 '列がそろったときに表示するメッセージ
 b = "ビンゴです！おめでとうございます！"
 If Range("b3,c3,d3,e3,f3") = Interior.ColorIndex = 7 Then
 Exit For
 MsgBox (b)
 Else
 If Range("b4,c4,d4,e4,f4") = Interior.ColorIndex = 7 Then
 Exit For
 MsgBox (b)
 Else
 If Range("b5,c5,d5,e5,f5") = Interior.ColorIndex = 7 Then
 Exit For
 MsgBox (b)
 Else
 If Range("b6,c6,d6,e6,f6") = Interior.ColorIndex = 7 Then
 Exit For
 MsgBox (b)
 Else
 If Range("b7,c7,d7,e7,f7") = Interior.ColorIndex = 7 Then
 Exit For
 MsgBox (b)
 Else
 If Range("b3,b4,b5,b6,b7") = Interior.ColorIndex = 7 Then
 Exit For
 MsgBox (b)
 Else
 If Range("c3,c4,c5,c6c7") = Interior.ColorIndex = 7 Then
 Exit For
 MsgBox (b)
 Else
 If Range("d3,d4,d5,d6,d7") = Interior.ColorIndex = 7 Then
 Exit For
 MsgBox (b)
 Else
 If Range("e3,e4,e5,e6,e7") = Interior.ColorIndex = 7 Then
 Exit For
 MsgBox (b)
 Else
 If Range("f3,f4,f5,f6,f7") = Interior.ColorIndex = 7 Then
 Exit For
 MsgBox (b)
 Else
 If Range("b3,c4,d5,e6,f7") = Interior.ColorIndex = 7 Then
 Exit For
 MsgBox (b)
 Else
 If Range("f3,e4,d5,c6,b7") = Interior.ColorIndex = 7 Then
 Exit For
 MsgBox (b)
 End If
 End If
 End If
 End If
 End If
 End If
 End If
 End If
 End If
 End If
 End If
 End If
 Next
 End Sub

とまぁ自分なりに考えてに書いてみたのですが、

実行すると「オブジェクトが必要です」と怒られてしまいます。

そして「 If Range("b3,c3,d3,e3,f3") = Interior.ColorIndex = 7 Then」のところに

黄色いマーカーが入ります。

私やりたいことが分かるでしょうか。

縦横斜め一列同じ色がそろったらforを中止してメッセージボックスを表示したいのです。

どこがいけないのか、分かる方ご指導ください。

 windowsXP

 Excel2003

---

 コード内容はほとんど見ていませんが
 If Range("b3,c3,d3,e3,f3") = Interior.ColorIndex = 7 Then
                            ↓
 If Range("b3,c3,d3,e3,f3") . Interior.ColorIndex = 7 Then
 に変えて下さい。

 (通行人)

---

通行人様、誠にありがとうございます！！

できました！できました！

思い通りに動きました！

感謝しきれません。

本当にありがとうございます！！！！！

（質問主）

---

 すでに解決したようですが、せっかく作ったのでアップします。

 推測ですが配置を合わせて、いますので下記のようにすれば、同じボタンから
 利用できると思います。

 Private Sub CommandButton2_Click()
    OpenNumber
 End Sub

 ところで、（比較の時に Range("b3,c3,d3,e3,f3")  のような使い方って
 動いています？

 '----------------------------------------------------
 Option Explicit

 Const MAX_NUMBER = 75
 Const CARD_TOPLEFT = "B3"
 Const INIT_COLOR = 35
 Const MATCH_COLOR = 7

 '----------------------------------------------------
 Sub Bingo()
    MakeCard
    OpenNumber
 End Sub

 '----------------------------------------------------
 Private Sub MakeCard()
    Dim ws As Worksheet
    If Worksheets(1).Name <> "BINGO CARD" Then
        Worksheets.Add before:=Worksheets(1)
        Worksheets(1).Name = "BINGO CARD"
    End If
    Set ws = Worksheets(1)
    ws.Cells.Interior.ColorIndex = 2

    With ws.Range(CARD_TOPLEFT).Resize(5, 5)
        .EntireRow.RowHeight = 50
        .EntireColumn.ColumnWidth = 6
        .Borders.LineStyle = xlContinuous
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .Characters.Font.Size = 24
        .Characters.Font.Bold = True
        .Interior.ColorIndex = INIT_COLOR
    End With
    With Range("H3:J5")
        .Merge
        .Borders.LineStyle = xlContinuous
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .Characters.Font.Size = 60
        .Characters.Font.Bold = True
    End With

    Dim i As Long
    For i = 0 To 4
    With Range("B10").Offset(i * 2, 0).Resize(1, 15)
        .Clear
        .EntireColumn.ColumnWidth = 6
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
    End With
    Next
    ws.Activate

    Dim randNums
    randNums = MakeRandomNumbers(MAX_NUMBER)

    Dim j As Long
    For i = 0 To 4
        For j = 0 To 4
            Range(CARD_TOPLEFT).Offset(i, j).Value = randNums(i * 5 + j + 1)
        Next
    Next
 End Sub

 '----------------------------------------------------
 Private Sub OpenNumber()

 '乱数を発生させる
    Dim 乱数
    乱数 = MakeRandomNumbers(MAX_NUMBER)

 '○回目のところの数字
    Dim j
    For j = 1 To 75
        Cells(2, 8) = j
        Range("h3:j5") = 乱数(j)

 '記録表
        Cells(10 + Int((j - 1) / 15) * 2, ((j - 1) Mod 15) + 2) = 乱数(j)

 '同じ番号に色を付ける
        Dim f As Range
        Set f = Range(CARD_TOPLEFT).Resize(5, 5).Find(乱数(j), lookat:=xlWhole)
        If Not f Is Nothing Then
            f.Interior.ColorIndex = MATCH_COLOR
            Cells(10 + Int((j - 1) / 15) * 2, ((j - 1) Mod 15) + 2).Interior.ColorIndex = MATCH_COLOR
        End If

        If CheckBingo(Range(CARD_TOPLEFT).Resize(5, 5)) = True Then
             MsgBox "ビンゴです！おめでとうございます！"
             Exit Sub
        End If

 '次の番号を出すか終わらせるかを問う質問
        If MsgBox("次は " & j & "番目です。続けますか？" & vbCrLf & _
            "終了する時はキャンセルを押してください。" _
            , vbOKCancel, j & "回目") = vbCancel Then Exit Sub
    Next
  End Sub

 '----------------------------------------------------
  Function MakeRandomNumbers(maxNum)
    Dim ar() As Long
    ReDim ar(maxNum)

    Dim i As Long
    For i = 1 To maxNum
        ar(i) = i
    Next

    Dim j As Long
    Dim k As Long
    Dim t As Long
    For i = 1 To 30
        For j = 1 To maxNum
            k = (Int(Rnd() * 1000) Mod maxNum) + 1
            t = ar(k)
            ar(k) = ar(j)
            ar(j) = t
        Next
    Next
    MakeRandomNumbers = ar
 End Function

 '----------------------------------------------------
 Function CheckBingo(card As Range) As Boolean
    Dim checkArray(12) As Long

    Dim i As Long
    Dim j As Long
    For i = 1 To 5
        For j = 1 To 5
            If card.Cells(i, j).Interior.ColorIndex = MATCH_COLOR Then
                checkArray(j) = checkArray(j) + 1
            End If
            If card.Cells(j, i).Interior.ColorIndex = MATCH_COLOR Then
                checkArray(j + 5) = checkArray(j + 5) + 1
            End If
        Next
        If card.Cells(i, i).Interior.ColorIndex = MATCH_COLOR Then
            checkArray(11) = checkArray(11) + 1
        End If
        If card.Cells(i, 6 - i).Interior.ColorIndex = MATCH_COLOR Then
            checkArray(12) = checkArray(12) + 1
        End If
    Next

    CheckBingo = False
    For i = 1 To 12
        If checkArray(i) = 5 Then
            CheckBingo = True
            Exit Function
        End If
    Next
 End Function
 '----------------------------------------------------
 (Mook)

---

 こんな方法も試してください。

 標準モジュールに

 '====================================================================
 Option Explicit
 Sub ビンゴゲーム()
    Dim 乱数 As Variant
    Dim g0 As Long
    Dim b As Variant
    Dim crng As Range
    With Cells
       .Interior.ColorIndex = xlNone
       .Clear
    End With
    乱数 = mk_rnd(75)
    g0 = 1
    For Each crng In Range("b3:f7")
       crng.Value = 乱数(g0)
       g0 = g0 + 1
    Next
    MsgBox "ビンゴゲーム開始"
    乱数 = mk_rnd(75)
    For g0 = 1 To 75
       Cells(2, 8).Value = g0
       Range("h3").Value = 乱数(g0)
       Cells(((g0 - 1) \ 15) * 2 + 10, (g0 - 1) Mod 15 + 2).Value = 乱数(g0)
       '同じ番号に色を付ける
       Call match_chk(Range("b3:f7"), Range("h3").Value, 7)
       '列がそろったときに表示するメッセージ
       b = "ビンゴです！おめでとうございます！"
       If Not Bingo(Range("b3:f7"), 7) Is Nothing Then
          MsgBox b
          Exit For
       End If
       '次の番号を出すか終わらせるかを問う質問
       If MsgBox(乱数(g0) & "番です。" & vbCrLf & _
           "終了する時はキャンセルを押してください。" _
           , vbOKCancel, g0 & "回目") = vbCancel Then End:
    Next
 End Sub
 '====================================================================
 Function Bingo(ByVal rng As Range, ByVal col As Long) As Range
 '指定されたセル範囲の縦・横・斜めのラインが指定色のセル範囲を返す
    Dim crng As Range
    Dim g0 As Long
    Set Bingo = Nothing
    For Each crng In rng.Rows
      If crng.Interior.ColorIndex = col Then
         Set Bingo = crng
         Exit For
      End If
    Next
    If Bingo Is Nothing Then
       For Each crng In rng.Columns
          If crng.Interior.ColorIndex = col Then
             Set Bingo = crng
             Exit For
          End If
       Next
    End If
    If Bingo Is Nothing Then
       If rng.Rows.Count = rng.Columns.Count Then
          Set crng = rng.Cells(1, 1)
          For g0 = 1 To rng.Rows.Count - 1
             Set crng = Union(crng, crng.Cells(1, 1).Offset(g0, g0))
          Next
          If crng.Interior.ColorIndex = col Then
             Set Bingo = crng
          End If
       End If
    End If
    If Bingo Is Nothing Then
       If rng.Rows.Count = rng.Columns.Count Then
          Set crng = rng.Cells(1, rng.Columns.Count)
          For g0 = 1 To rng.Rows.Count - 1
             Set crng = Union(crng, crng.Cells(1, 1).Offset(g0, -g0))
          Next
          If crng.Interior.ColorIndex = col Then
             Set Bingo = crng
          End If
       End If
    End If
 End Function
 '====================================================================
 Sub match_chk(ByVal rng As Range, myval As Variant, col As Long)
 '指定されたセル範囲が指定値のセルを指定色に塗りつぶす
    Dim rst As Variant
    Dim ans As Variant
    Dim g0 As Long
    rst = Evaluate("=" & rng.Address(, , , True) & "=" & myval)
    For g0 = LBound(rst, 1) To UBound(rst, 1)
       With Application
          ans = .Match(True, .Index(rst, g0, 0), 0)
       End With
       If Not IsError(ans) Then
          rng.Cells(g0, ans).Interior.ColorIndex = col
          Exit For
       End If
    Next
 End Sub
 '====================================================================
 Function mk_rnd(lim As Long) As Variant
 '1〜指定値までの数字をランダムに並べた配列を返す
   Dim g0 As Long
   Dim g1 As Long
   Dim col As Collection
   Set col = New Collection
   For g0 = 1 To lim
      col.Add g0
   Next
   ReDim wk(1 To lim)
   Randomize
   g0 = 1
   Do While col.Count > 0
     g1 = Int(Rnd * col.Count) + 1
     wk(g0) = col(g1)
     col.Remove g1
     g0 = g0 + 1
   Loop
   mk_rnd = wk()
   Set col = Nothing
   Erase wk()
 End Function

 ビンゴゲームを実行してみてください。

 ichinose

---

 >ところで、（比較の時に Range("b3,c3,d3,e3,f3")  のような使い方って
 >動いています？

 これについては、
 If Range("b3,c3,d3,e3,f3").Interior.ColorIndex = 7 Then

 このステートメントでいけそうですよ！！
 但し、Range("b3,c3,d3,e3,f3").Interior.ColorIndex 　この結果がNullを返す
 ことがある　ということは認識していないと面倒なことが起きる可能性もありそうです。

 例　新規ブックにて試してください。
 標準モジュールに

 '=================================================================
 Sub sample()
    With Range("b3,c3,d3,e3,f3")
       .Interior.ColorIndex = xlNone
       .Range("a1:e1").Interior.ColorIndex = 7
       MsgBox "この状態で" & vbCrLf & _
              "If Range(""b3,c3,d3,e3,f3"").Interior.ColorIndex = 7 Then" & vbCrLf & _
              "   MsgBox Range(""b3,c3,d3,e3,f3"").Address & ""　の塗りつぶし色は全部　ピンク""" & vbCrLf & _
              "Else" & vbCrLf & _
              "   MsgBox Range(""b3,c3,d3,e3,f3"").Address & ""　の塗りつぶし色は全部がピンクではない""" & vbCrLf & _
              "End If" & vbCrLf & _
              "上記のコードを実行すると・・・・・"
       If .Interior.ColorIndex = 7 Then
          MsgBox .Address & "　の塗りつぶし色は全部　ピンク"
       Else
          MsgBox .Address & "　の塗りつぶし色は全部がピンクではない"
       End If
       MsgBox "と　　この状態だと正常に作動します。又、"
       .Interior.ColorIndex = xlNone
       .Range("a1:b1").Interior.ColorIndex = 7
       MsgBox "この状態で" & vbCrLf & _
              "If Range(""b3,c3,d3,e3,f3"").Interior.ColorIndex = 7 Then" & vbCrLf & _
              "   MsgBox Range(""b3,c3,d3,e3,f3"").Address & ""　の塗りつぶし色は全部　ピンク""" & vbCrLf & _
              "Else" & vbCrLf & _
              "   MsgBox Range(""b3,c3,d3,e3,f3"").Address & ""　の塗りつぶし色は全部がピンクではない""" & vbCrLf & _
              "End If" & vbCrLf & _
              "上記のコードを実行すると・・・・・"
       If .Interior.ColorIndex = 7 Then
          MsgBox .Address & "　の塗りつぶし色は全部　ピンク"
       Else
          MsgBox .Address & "　の塗りつぶし色は全部がピンクではない"
       End If
       MsgBox "これも正常に作動していますが・・・・。前回のIF文をこのようにすると・・・。"
       MsgBox "If Range(""b3,c3,d3,e3,f3"").Interior.ColorIndex <> 7 Then" & vbCrLf & _
              "   MsgBox Range(""b3,c3,d3,e3,f3"").Address & ""　の塗りつぶし色は全部がピンクではない""" & vbCrLf & _
              "Else" & vbCrLf & _
              "   MsgBox Range(""b3,c3,d3,e3,f3"").Address & ""　の塗りつぶし色は全部　ピンク""" & vbCrLf & _
              "End If" & vbCrLf & _
              "上記のコードを実行すると・・・・・"
       If .Interior.ColorIndex <> 7 Then
          MsgBox .Address & "　の塗りつぶし色は全部　ピンクではない"
       Else
          MsgBox .Address & "　の塗りつぶし色は全部がピンク"
       End If
       MsgBox "If条件を逆にしても、結果は、Falseの処理を行っています。" & vbCrLf & _
              "ここでNullであることを忘れていると思わぬ　落とし穴がありますから　注意してください"
    End With
 End Sub

 ichinose@Excel2002で確認

---

 ichinose さん、検証ありがとうございました。

 文法のはざまを突くような使い方で、できるからと言って使いたいやり方では
 ありませんが、動くんですねぇ。

 勉強になりました。
 (Mook)

---

 単純に作ってみましたが・・・ダメですかね？
 色じゃなくてワークシート関数で。

 Private Sub CommandButton2_Click()
 Dim myC As New Collection
 Dim i As Long
 Dim myRnd As Long

 With Range("B3:F7")
   .FormatConditions.Delete
   .FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF($B$10:$P$18,B3)>0"
   .FormatConditions(1).Interior.ColorIndex = 7
 End With
 Range("AA3:AE7").Formula = "=COUNTIF($B$10:$P$18,B3)"
 Range("AF3:AF7").Formula = "=SUM(AA3:AE3)"
 Range("AA8:AE8").Formula = "=SUM(AA3:AA7)"
 Range("AA9").Formula = "=SUM(AA3,AB4,AC5,AD6,AE7)"
 Range("AB9").Formula = "=SUM(AA7,AB6,AC5,AD4,AE3)"

 For i = 1 To 75
   myC.Add i
 Next i

 Randomize
 For i = 1 To 75
   Range("H2").Value = i
   myRnd = Int(Rnd() * myC.Count + 1)
   Range("H3").Value = myC.Item(myRnd)
   Range("B10:P10,B12:P12,B14:P14,B16:P16,B18:P18").Cells(i).Value = myC.Item(myRnd)
   If MsgBox(myC.Item(myRnd) & "番です。" & vbCrLf & _
             "終了する時はキャンセルを押してください。", vbOKCancel, i & "回目") = vbCancel Then
     Exit Sub
   End If
   If Application.WorksheetFunction.Max(Range("AA3").CurrentRegion) = 5 Then
     MsgBox "ビンゴです！おめでとうございます！"
   End If
   myC.Remove (myRnd)
 Next i
 End Sub

 （ｍｏｍｏ）

---

 >色じゃなくてワークシート関数で。
 へえ、面白い方法ですねえ！！
 一つだけ・・・、
 With Range("B3:F7")
   .Select
   .FormatConditions.Delete
   .FormatConditions.Add Type:=xlExpression,Formula1:="=COUNTIF($B$10:$P$18,B3)>0"
   .FormatConditions(1).Interior.ColorIndex = 7
 End With

 としておかないと=COUNTIF($B$10:$P$18,B3)>0　
 この数式が正しい相対アドレスになりませんね！！

 ichinose

---

 ichinoseさんに面白がってもらえて光栄です。
 おっと・・・相対アドレスでしたね・・・IV65536とかなっちゃいますね。

 最初から
 .FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF(R10C2:R18C16,RC)>0"
 とでもしておけば良かったですね〜

 ご指摘ありがとうございます(^^)

 （ｍｏｍｏ）

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.