脳トレ計算

某有名ゲームの簡単な計算問題を
VBAでやります。

最近、脳みその活動レベルが低下しているなと
自覚している人にお薦めです。
２桁対１桁の計算をしたときに
脳みそがシュワシュワするのを感じました。

まずは準備です。
コードはこちら

Sub macro101218z()
'macro101218系準備

    Sheets.Add.Name = "結果"
    With Sheets("結果")
        .Cells(1, 1) = "x"
        .Cells(1, 2) = "Ope"
        .Cells(1, 3) = "y"
        .Cells(1, 4) = "="
        .Cells(1, 5) = "回答"
        .Cells(1, 6) = "正誤"
        .Cells(1, 7) = "時間"
        .Cells(1, 8) = "所要時間(秒)"
        .Cells(2, 11) = "回答問題数"
        .Cells(3, 11) = "総所要時間(秒)"
        .Cells(4, 11) = "平均所要時間(秒)"
        .Cells(5, 11) = "正解率"
    End With
   
   
    Sheets.Add.Name = "問題"
    ActiveSheet.Cells.Interior.ColorIndex = 2
    With ActiveSheet.Cells(20, 10).Borders
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = 1
    End With
   
    ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _
        , DisplayAsIcon:=False, Left:=600.75, Top:=217.5, Width:=64.5, Height _
        :=24).Select
    ActiveSheet.OLEObjects.Item(1).Object.Caption = "開始"
    Randomize
   
End Sub

上のコードを実行すると
”問題”と”結果”の２つのシートが作成されます。

”問題”のシートにはボタンを作成してあります。
このままではボタンを押しても何も実行されませんので、
次のプロシージャを
”問題”シートのオブジェクトモジュールに
コピペしてください。

Private Sub CommandButton1_Click()
'スタート

    Randomize    ' 乱数発生ルーチンを初期化します。
    Call macro101218b '前回のデータ削除
    Sheets("結果").Range("G2") = Now '開始時間
    Call macro101218a '出題
   
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> Range("J20").Column Then Exit Sub
    If Target.Row <> Range("J20").Row Then Exit Sub
   
    Dim MyTime As Date
    MyTime = Now
   
    Dim sh1 As Object
    Set sh1 = ActiveWorkbook.Sheets("問題")
   
    With Sheets("結果")
        .Range("A2:H2").Insert shift:=xlDown
        .Range("G2") = MyTime '回答時間
        .Range("G2").NumberFormatLocal = "hh:mm:ss"
        '所要時間（秒）
        .Range("H2") = (.Range("G2") - .Range("G3")) * 86400
    End With
   
    '正誤の確認
    Dim x As Integer
    Dim y As Integer
    Dim Ans As Integer
    x = sh1.Cells(20, 6).Value
    y = sh1.Cells(20, 8).Value
    Ans = sh1.Cells(20, 10)
    sh1.Cells(20, 11).Font.Size = 24
    sh1.Cells(20, 11).Font.ColorIndex = 3
   
    Select Case sh1.Cells(20, 7)
        '演算子で分岐
        Case "＋"
            If x + y = Ans Then
                sh1.Cells(20, 11) = "正解"
            Else
                sh1.Cells(20, 11) = "不正解"
                Beep
            End If
        Case "－"
            If x - y = Ans Then
                sh1.Cells(20, 11) = "正解"
            Else
                sh1.Cells(20, 11) = "不正解"
                Beep
            End If
        Case "×"
            If x * y = Ans Then
                sh1.Cells(20, 11) = "正解"
            Else
                sh1.Cells(20, 11) = "不正解"
                Beep
            End If
        Case "÷"
            If x / y = Ans Then
                sh1.Cells(20, 11) = "正解"
            Else
                sh1.Cells(20, 11) = "不正解"
                Beep
            End If
    End Select
   
    With Sheets("結果")
        .Range("A2:F2") = Range("F20:K20").Value '問題を結果シートに
        .Range("L2") = .Range("A1").End(xlDown).Row - 1 '問題数
        .Range("L3") = (.Range("G2") - .Range("G1").End(xlDown)) * 24 * 60 * 60 '所要時間
        .Range("L4") = .Range("L3") / .Range("L2") '平均所要時間
       
        '正解率
        Dim c As Integer
        Dim i As Integer
        For i = 2 To .Range("G1").End(xlDown).Row
            If .Cells(i, 6) = "正解" Then
                c = c + 1
            End If
        Next i
        .Range("L5") = c / .Range("L2") * 100 & "%"
        .Columns.AutoFit
    End With
   
    Application.Wait Now + TimeValue("00:00:01")
    '次の問題へ
    sh1.Range("F20:K20") = ""
    Call macro101218a
   
End Sub

次が計算問題実行する本体などのプロシージャです。

Sub macro101218b()
'結果シートをクリア

    With Sheets("結果")
        .Range("A2:H" & Rows.count).Clear
        .Range("L2:L5").Clear
    End With
   
End Sub
Sub macro101218a()
'脳トレ計算

    Dim x As Integer, y As Integer
    Dim ketaX As Integer, ketaY As Integer
    Dim OpeIndex As Integer
    Dim Ope(4) As String
    Ope(1) = "＋"
    Ope(2) = "－"
    Ope(3) = "×"
    Ope(4) = "÷"
   
    'xとyの桁数
    ketaX = 2
    ketaY = 1
   
    'x,y,演算子を決定
    OpeIndex = Int(4 * Rnd) + 1
    x = Int(10 ^ ketaX * Rnd)
    y = Int(10 ^ ketaY * Rnd)
   
    '割り算の場合
    If OpeIndex = 4 Then
        '0以外で割り算のときyを割り切れる数にする
        Do While y = 0
            y = Int(10 * Rnd)
        Loop
        Do While x Mod y <> 0
            y = Int(10 * Rnd)
            Do While y = 0
                y = Int(10 * Rnd)
            Loop
        Loop
    End If
   
    '問題を出力
    With Sheets("問題")
        .Range("F20:J20").Font.Size = 24
        .Cells(20, 6) = x
        .Cells(20, 7) = Ope(OpeIndex)
        .Cells(20, 8) = y
        .Cells(20, 9) = "＝"
        Range("F20:I20").Columns.AutoFit
        .Cells(20, 10).Select
       
    End With
   
End Sub

これで”問題”シートの「開始」ボタンを押すと
計算問題を開始できます。

それぞれのコードは単純なので
大体の流れだけ説明します。

まず最初に「開始」ボタンを押すと、
”問題”シートのオブジェクトモジュールの
CommandButton1_Click が実行されます。

この中で
開始時間が”結果”シートに記録され、
macro101218b で前回のデータ削除、
macro101218a で出題されます。

回答の正誤判定は
macro101218a で選択されたセルJ20に
答えを入力すると自動的にされます。

これはWorksheetのChangeイベントで発動します。
WorksheetのChangeイベントは該当シートの
どこかのセルの値が変わったときに発生します。

今は回答用のセルJ20以外は
Ifステートメントで判別して無視しています。

回答の正誤判定が終わったら
問題と回答、正誤判定を”結果”シートにも入れます。
簡単な統計を計算して表示します。

これで1回の計算が終わり、次の計算が出題されます。

問題の回数は任意です。
好きなだけ連続してできます。

2回目に計算を連続してするときに
「開始」ボタンを押してください。

「開始」ボタンを押さないと
所要時間に何もしていない時間まで含められて
時間が正確にでません。

実行の様子： ”問題”シート

”結果”シート

なかなかハマります。