Excel VBA こどもと一緒にさんすうツール

ExcelVBA-実用編

今回は作成したツールをご紹介します。

遊び心で作ったツールである事はご了承ください。

タイトルの通り、子供と一緒にさんすうの勉強ができるツールです。

このツールをそのまま使うというよりも、こういうものも手軽に作れるというご紹介となります。

一番最後にサンプルファイルと全コードを記載します。

コードをコピーして作成する場合は、「図の挿入」等の準備が必要です

1.ツールの動画

まず最初に動画でどのようなツールかご覧ください。

※動画はわざと3問目を難しくしています。

2.ツールの目的

このツールを作った目的は大きく2つです。

1つ目は難しいコードやロジックをほとんど使わずに、比較的簡単にこのようなツールを作れるというご紹介です。

2つ目は子供にさんすうを楽しみながら練習してもらいながら、Excelに自然と慣れてもらう。

「これはどうやってうごいているの?」と興味をもってもらえたら最高ですね。

3.工夫した部分

無機質な計算を延々とさせるより、楽しいと感じながらできるよう工夫してみました。

また、セリフや文字は小さな子供でも読めるようにひらがなのみ使用しています。

VBA自体も複雑な作りにならないよう、簡単な書き方にしています。

4.使い方

簡単な使い方のご説明をします。

「さいしょから」をクリックすると猫が最初のセリフを表示します。

開始をクリックすると、「1もんめ〜」というセリフが表示され、問題が表示されます。

設定数分の問題を正解すると、最初に戻ります。

途中で間違えても最初に戻ります。

また、途中で「さいしょから」をクリックしても最初に戻ります。

実は「かいし」を押しても最初からになります。

5.コードの解説

コードの解説です。

ロジックもコーディングも極力簡単に書きました。

コードは大きく分けて2つに分かれます。

Sheet1モジュールに書かれた、特定のセル(F10)が変更された際のイベントと、標準モジュールに書かれた機能部分の各パーツとなります。

順番にご説明します。

Sheet1モジュールのコード

Sheet1モジュールに書かれたコードの説明です。

F10が変更された時に、計算結果をチェックするコードを呼び出します。

Sheet1(Sheet1)モジュールに「Worksheet_Change」イベントを選択して次のコードを書きます。

「If Intersect(Target, Range(“F10”)) Is Nothing Then」で「F10」以外はプロシージャを抜け、「F10」が変更された時に、「F10」が空白じゃなければ「計算結果のチェック」を呼び出しています。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("F10")) Is Nothing Then
        Exit Sub
    Else
    
        If Cells(10, 6) <> "" Then
            Call myCheck
        End If
    End If

End Sub

標準モジュールのコード

標準モジュールに書かれたコードの説明です。

プロシージャは「計算結果をチェック」、「かいしボタン」、「さいしょからボタン」、「セルをクリア」、「問題用の整数を作成」、「メッセージ内容」の6つに分けました。

長くなるので、簡単に説明します。

宣言セクション

こちらで、「Sleep関数」と「現時点の問題数」と「問題数の設定」を宣言しています。

宣言セクションとは、モジュール内の一番上のプロシージャよりさらに上の部分です。

#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If
Public myCount   As Long
Const LastCount As Long = 3 '問題数を指定
計算結果をチェック

こちらで、回答のチェックを行っています。

最初に回答が正しいか判定し、正しい場合に問題数で表示するメッセージを選択しています。

メッセージ選択後、次の実行を分岐します。

最後に間違った場合のコードです。

※デフォルトでは間違えると「でなおしてこい」となっているため、「Function MsgStr」で便宜変更して下さい。

Sub myCheck()

    '回答チェック
    '問題数チェック(デフォルト3)
    
    Dim MyStr       As String
    Dim StrFlag     As String
    
    With ActiveSheet
        
        If .Cells(10, 2) + .Cells(10, 4) = .Cells(10, 6) Then '最初に回答が正しいかチェック
            
            myCount = myCount + 1
            
            If myCount = LastCount Then 'ラストの問題
            
                StrFlag = "Last" 'メッセージの選択キーワード
                
            ElseIf myCount < LastCount Then 'ラスト未満の問題
            
                StrFlag = "Correct" 'メッセージの選択キーワード
                        
            Else 'それ以外(全て正解)
            
                StrFlag = "AllCorrect" 'メッセージの選択キーワード
                
                myCount = 1 '問題数をリセット
                        
            End If

            With ActiveSheet.Shapes("角丸四角形吹き出し 3") 'テキストにメッセージとサイズを反映
                
                .Width = 110
                .Left = 500
                .Top = 30
                .TextFrame.Characters.Text = MsgStr(StrFlag)
            
            End With
                        
            Sleep 2000
            
            If StrFlag = "AllCorrect" Then
            
                Call CellClear 'セルクリア
                
            Else
            
                Call IntMaker '整数生成
                
                .Cells(10, 6) = ""
            
            End If
            
        Else
        
            StrFlag = "Mistake"
        
            With ActiveSheet.Shapes("角丸四角形吹き出し 3")
                
                .Width = 110
                .Left = 500
                .Top = 30
                .TextFrame.Characters.Text = MsgStr(StrFlag)
            
            End With
            
            Call CellClear 'セルクリア
                    
        End If
        
    End With

End Sub
「かいし」と「さいしょから」ボタン

「かいし」と「さいしょから」ボタンをクリックされた時のコードです。

テキストボックスのサイズとメッセージを表示するコードです。

Sub Start_Click()
    
    '「かいし」ボタンクリック時のコード
    
    Dim MyStr   As String
    
    myCount = 1

    Call IntMaker '整数生成

    With ActiveSheet.Shapes("角丸四角形吹き出し 3")
        
        .Width = 100
        .Left = 500
        .Top = 30
        .TextFrame.Characters.Text = MsgStr("Start")
    
    End With

End Sub

Sub ReStart_Click()

    '「さいしょから」ボタンをクリックした時のコード

    Dim MyStr As String
            
    Call CellClear 'セルクリア
    
    With ActiveSheet.Shapes("角丸四角形吹き出し 3")
        .Width = 200
        .Left = 520
        .Top = 30
        .TextFrame.Characters.Text = MsgStr("ReStart")
    
    End With
    
End Sub
セルクリア

B10、D10、F10をクリアするだけのコードです。

Function CellClear()

    'セルクリア

    With ActiveSheet
    
        .Cells(10, 2) = ""
        .Cells(10, 4) = ""
        .Cells(10, 6) = ""
    
    End With

End Function
問題用の整数を作成する

単精度小数点型の乱数を返す「Rnd関数」を使用して、ランダムに数字を出力して、設定したLow、Hight内の整数を作成しています。

「Const low As Integer = 1」と「Const high As Integer = 10」の数字を変更すると出力範囲が変更されます。

Low=1、High=100とすると1~100で出題されます。

Function IntMaker()

    '計算用整数作成
    '整数1~10(デフォルト1~10)
    Const low   As Integer = 1
    Const high  As Integer = 10
    Dim i       As Long
    
    Randomize
    
    With ActiveSheet
    
        i = Int((high - low + 1) * Rnd + low)
    
        .Cells(10, 2) = i
    
        i = Int((high - low + 1) * Rnd + low)
        
        .Cells(10, 4) = i
    
    End With

End Function
テキストのメッセージ選択

こちらで予め作成されたメッセージを選択しています。

「& vbCrLf & _」はメッセージを改行しています。

変数の「LastCount」、「myCount」は書き換えない様にしてください。

こちらの内容を書き換えると、適宜表示されるメッセージが変更されます。

※上記でも触れましたが、ミスの場合のメッセージが「でなおしてこい」なので、修正して下さい。

Function MsgStr(ByVal StrFlag As String) As String

    '表示文字列
    
    Select Case StrFlag

    Case "First"
    
        '===================最初======================
    
        MsgStr = "さんすうのれんしゅうだよ!" & vbCrLf & _
                LastCount & "もんせいかいしたら" & vbCrLf & _
                "おこづかいがもらえるよ!" & vbCrLf & _
                "かいしをおしてね!" & vbCrLf & _
                "やりなおすときはさいしょからをおしてね!"
    
    Case "Start"
    
        '===================開始======================
    
        MsgStr = myCount & "もんめだよ!" & vbCrLf & _
                "わかるかな?" & vbCrLf & _
                "がんばってね!"
    
    Case "ReStart"
    
        '================さいしょから==================
        
        MsgStr = "さんすうのれんしゅうだよ!" & vbCrLf & _
            "3もんせいかいしたら" & vbCrLf & _
            "おこづかいがもらえるよ!" & vbCrLf & _
            "かいしをおしてね!" & vbCrLf & _
            "やりなおすときはさいしょからをおしてね!"
        
    
    Case "Last"
    
        '===================最後======================
        
        MsgStr = "だいせいかい!" & vbCrLf & _
                "すごいすごいっ" & vbCrLf & _
                "さあさいごだよ!" & vbCrLf & _
                "わかるかな!?"
        
    Case "Correct"
    
        '===================正解======================
    
        MsgStr = "だいせいかい!" & vbCrLf & _
                "すごいすごいっ" & vbCrLf & _
                myCount & "もんめだよ!"
    
    
    Case "AllCorrect"
    
        '=================全問正解====================
        
        MsgStr = "だいせいかい!" & vbCrLf & _
                "すごーい!" & vbCrLf & _
                "ぜんぶせいかいだよ!"
                
    Case "Mistake"
        
        '=================計算ミス====================
        
        MsgStr = "でなおしてこい"
        
    End Select

End Function

6.全コード

Sheet1(Sheet1)モジュール

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("F10")) Is Nothing Then
        Exit Sub
    Else
    
        If Cells(10, 6) <> "" Then
            Call myCheck
        End If
    End If

End Sub

Module1

Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If
Public myCount   As Long
Const LastCount As Long = 3 '問題数を指定

Sub myCheck()

    '回答チェック
    '問題数チェック(デフォルト3)
    
    Dim MyStr       As String
    Dim StrFlag     As String
    
    With ActiveSheet
        
        If .Cells(10, 2) + .Cells(10, 4) = .Cells(10, 6) Then '最初に回答が正しいかチェック
            
            myCount = myCount + 1
            
            If myCount = LastCount Then 'ラストの問題
            
                StrFlag = "Last" 'メッセージの選択キーワード
                
            ElseIf myCount < LastCount Then 'ラスト未満の問題
            
                StrFlag = "Correct" 'メッセージの選択キーワード
                        
            Else 'それ以外(全て正解)
            
                StrFlag = "AllCorrect" 'メッセージの選択キーワード
                
                myCount = 1 '問題数をリセット
                        
            End If

            With ActiveSheet.Shapes("角丸四角形吹き出し 3") 'テキストにメッセージとサイズを反映
                
                .Width = 110
                .Left = 500
                .Top = 30
                .TextFrame.Characters.Text = MsgStr(StrFlag)
            
            End With
                        
            Sleep 2000
            
            If StrFlag = "AllCorrect" Then
            
                Call CellClear 'セルクリア
                
            Else
            
                Call IntMaker '整数生成
                
                .Cells(10, 6) = ""
            
            End If
            
        Else
        
            StrFlag = "Mistake"
        
            With ActiveSheet.Shapes("角丸四角形吹き出し 3")
                
                .Width = 100
                .Left = 500
                .Top = 30
                .TextFrame.Characters.Text = MsgStr(StrFlag)
            
            End With
            
            Call CellClear 'セルクリア
                    
        End If
        
    End With

End Sub

Sub Start_Click()
    
    '「かいし」ボタンクリック時のコード
    
    Dim MyStr   As String
    
    myCount = 1

    Call IntMaker '整数生成

    With ActiveSheet.Shapes("角丸四角形吹き出し 3")
        
        .Width = 100
        .Left = 500
        .Top = 30
        .TextFrame.Characters.Text = MsgStr("Start")
    
    End With

End Sub

Sub ReStart_Click()

    '「さいしょから」ボタンをクリックした時のコード

    Dim MyStr As String
            
    Call CellClear 'セルクリア
    
    With ActiveSheet.Shapes("角丸四角形吹き出し 3")
        .Width = 200
        .Left = 520
        .Top = 30
        .TextFrame.Characters.Text = MsgStr("ReStart")
    
    End With
    
End Sub

Function CellClear()

    'セルクリア

    With ActiveSheet
    
        .Cells(10, 2) = ""
        .Cells(10, 4) = ""
        .Cells(10, 6) = ""
    
    End With

End Function

Function IntMaker()

    '計算用整数作成
    '整数1~10(デフォルト1~10)
    Const low   As Integer = 1
    Const high  As Integer = 10
    Dim i       As Long
    
    Randomize
    
    With ActiveSheet
    
        i = Int((high - low + 1) * Rnd + low)
    
        .Cells(10, 2) = i
    
        i = Int((high - low + 1) * Rnd + low)
        
        .Cells(10, 4) = i
    
    End With

End Function

Function MsgStr(ByVal StrFlag As String) As String

    '表示文字列
    
    Select Case StrFlag

    Case "First"
    
        '===================最初======================
    
        MsgStr = "さんすうのれんしゅうだよ!" & vbCrLf & _
                LastCount & "もんせいかいしたら" & vbCrLf & _
                "おこづかいがもらえるよ!" & vbCrLf & _
                "かいしをおしてね!" & vbCrLf & _
                "やりなおすときはさいしょからをおしてね!"
    
    Case "Start"
    
        '===================開始======================
    
        MsgStr = myCount & "もんめだよ!" & vbCrLf & _
                "わかるかな?" & vbCrLf & _
                "がんばってね!"
    
    Case "ReStart"
    
        '================さいしょから==================
        
        MsgStr = "さんすうのれんしゅうだよ!" & vbCrLf & _
            LastCount & "もんせいかいしたら" & vbCrLf & _
            "おこづかいがもらえるよ!" & vbCrLf & _
            "かいしをおしてね!" & vbCrLf & _
            "やりなおすときはさいしょからをおしてね!"
        
    
    Case "Last"
    
        '===================最後======================
        
        MsgStr = "だいせいかい!" & vbCrLf & _
                "すごいすごいっ" & vbCrLf & _
                "さあさいごだよ!" & vbCrLf & _
                "わかるかな!?"
        
    Case "Correct"
    
        '===================正解======================
    
        MsgStr = "だいせいかい!" & vbCrLf & _
                "すごいすごいっ" & vbCrLf & _
                myCount & "もんめだよ!"
    
    
    Case "AllCorrect"
    
        '=================全問正解====================
        
        MsgStr = "だいせいかい!" & vbCrLf & _
                "すごーい!" & vbCrLf & _
                "ぜんぶせいかいだよ!"
                
    Case "Mistake"
        
        '=================全問正解====================
        
        MsgStr = "でなおしてこい"
        
    End Select

End Function

7.サンプルファイル

こちらからサンプルファイルをダウンロードできます。

タイトルとURLをコピーしました