Excel でビンゴ の続き ～ 抽選している気分を醸し出す視覚効果 ～

先日、ビンゴ抽選用のマクロを作成した話を紹介しました。

infoment.hatenablog.com

その後、親戚で集まった際にもう一度使う機会があって、少し改修してみました。

［改修内容］

• 抽選前にランダムな数字を複数表示し、高速で10回切り替える。
• 切り替えるたびに、文字色を変更する。
• 表示から次の表示までの間隔は、0.05秒とする。

実際に追加したのは、↓の部分です。

        For j = 1 To 10
            TempNumber = Rnd * 75
            TempColor = Rnd * 255 * 255 * 255
            With Cells(1, "J")
                .Value = TempNumber
                On Error Resume Next                    ' ①
                .Font.Color = TempColor
                On Error GoTo 0
                Application.Wait [now()+"0:00:00.05"]   ' ②
            End With
        Next

① の「エラー無視」について

景気よく抽選を繰り返していたところ、見たこともないエラーが出ました。

一時的に？フォント情報を記録していて、上限を超えるとエラーが出るようです。今回のようにカラフルな Excel の資料を普段作ることがないため、発生するのは稀なことかも。Excel の再起動で元に戻るため、とりあえずエラー無視で対応です。

② の「待ち時間0.05秒」について

今回調べてみて分かったのですが、Application.Wait で１秒未満の時間を指定する場合、このような指定方法があるようです。

 Application.Wait [now()+"0:00:00.05"]

忘れないうちに、ここにメモです。

上記を追加した結果、抽選気分を味わうことが出来るようになりました。

最後に、抽選部分のコード全文を載せておきます。

Sub Bingo()

    Dim i As Long
        If Dict Is Nothing Then
            Set Dict = New Dictionary
        End If
        i = Dict.Count + 1

    Dim MsgboxResult As VbMsgBoxResult
        If i >= 76 Then
            MsgboxResult = MsgBox("最後のボールです。リセットしますか？", vbYesNo)
            If MsgboxResult = vbYes Then
                Call Reset
            End If
            Exit Sub
        End If
        
    Dim j As Long
    Dim TempNumber As Long
    Dim TempColor  As Long
    
        For j = 1 To 10
            TempNumber = Rnd * 75
            TempColor = Rnd * 255 * 255 * 255
            With Cells(1, "J")
                .Value = TempNumber
                On Error Resume Next
                .Font.Color = TempColor
                On Error GoTo 0
                Application.Wait [now()+"0:00:00.05"]
            End With
        Next
    
        Do
            TempNumber = GetRandomNumber(1, 75)
            If Dict.Exists(TempNumber) = False Then
                Dict(TempNumber) = i
                Exit Do
            End If
        Loop

        Cells(i, "A") = TempNumber
        Cells(1, "J") = TempNumber
        Cells(1, "J").Font.Color = -16777024

End Sub

娘も更に喜んでくれたので、良かったのかな？と思います。

参考まで。