以前に100枡計算ツールを息子のために作ったのだが、学校で筆算を習うようになったので筆算のツールを作って欲しいとせがまれてしまった。
子供のリクエストとあらば答えねばなるまい!
完成品
完成品はこちらです。
足し算の動きはこんな感じです
引き算
掛け算
設定
使用するにあたって各種の設定を行います。
設定名 | 項目 |
---|---|
計算種類 | たしざん・ひきざん・かけざんから選択 |
オプション | 現時点では引き算のみ設定あり。 ・答えがマイナスにならないように出題 |
上の段 下の段 最小値 最大値 |
出題される数値の範囲を設定します。 0~999の間で設定することが出来ます。 |
問題数 | 出題される問題数を設定することが出来ます。 1~100の間で設定することが出来ます |
解答
スタートボタンを押すと出題され、解答モードになります。
解答モード中は解答入力欄(K5セル)とおわりボタン以外は触ることができなくなります。
そのため解答入力→Enter→解答入力とスムーズに進めることが出来ます。
指定した問題数を解答するか終わりボタンを押すことで解答モードが終了します。
解答履歴
解答モード中に解答するたびにこの欄に解答が一番上に蓄積されていきます。
○×の色は条件付き書式で設定しています。
コード
今回はセルに名前定義をしまくっています。
だいたいは名前を見ればどこを指しているかは解って頂けると思いますが、2つだけセルの文字を白色にして見えなくしています。
・解答数・・・現在何問目を解いているかを記載しています。
・解答中・・・解答モードの場合1を記載しています。
コードの構成はこうなっています。
以下はwsCalcワークシートに記載されています。
wsCalcワークシート
'スタートボタン Private Sub CommandButton1_Click() With wsCalc If 問題判定 Then .Range("解答").Activate .Range("解答数").Value = "" '1で解答モードon。シートの保護機能をON。Range(”解答")以外はロックがかかっているため触れなくなる .Range("解答中").Value = 1 .Range("解答履歴").ClearContents 'スタートボタンを非アクティブにする .CommandButton1.Enabled = False '計算種類が選択されていない場合は「たしざん」が選ばれたとみなす If .Range("計算種類").Value = "" Then .Range("計算種類").Value = "たしざん" Select Case .Range("計算種類").Value Case "たしざん" .Range("下段出題").Offset(, -1).Value = "+" Case "ひきざん" .Range("下段出題").Offset(, -1).Value = "ー" Case "かけざん" .Range("下段出題").Offset(, -1).Value = "×" End Select .Protect 出題 .Range("計算種類").Value Else MsgBox "最小値を最大値以下に設定してください", vbInformation + vbOKOnly, "問題設定エラー" End If End With End Sub '------------------------------------------------------------' 'おわりボタン Private Sub CommandButton2_Click() wsCalc.Unprotect wsCalc.Range("解答中").Value = "" wsCalc.Range("解答数").Value = "" wsCalc.CommandButton1.Enabled = True End Sub '------------------------------------------------------------' Private Sub Worksheet_Change(ByVal Target As Range) 'セル内容を変更したセルのアドレスがRange("解答")のアドレスと一致、かつ解答中モード(スタートボタンを押した後)である場合 If Target.Address = Range("解答").Address And wsCalc.Range("解答中").Value = 1 Then wsCalc.Range("解答").Activate 出題 wsCalc.Range("計算種類").Value 'セル内容を変更したセルのアドレスがRange("計算種類")のアドレスと一致した場合、オプション設定を初期化 ElseIf Target.Address = Range("計算種類").Address Then Range("オプション").Value = "" End If End Sub '------------------------------------------------------------ '問題の設定のチェック Private Function 問題判定() As Boolean Dim UeMax As Long Dim UeMin As Long Dim SitaMax As Long Dim SitaMin As Long Dim tmp As Boolean tmp = True With wsCalc UeMax = .Range("上段最大値").Value UeMin = .Range("上段最小値").Value SitaMax = .Range("下段最大値").Value SitaMin = .Range("下段最小値").Value End With ' 上の段・下の段どちらかが最小値が最大値を上回っている場合にfalseを返す If UeMin > UeMax Or SitaMin > SitaMax Then tmp = False End If 問題判定 = tmp End Function
スタートボタンを押すとシート保護されます。 解答入力欄以外はロックがかかりますので解答欄以外にカーソルが行くことがありません。
標準モジュール
Option Explicit Sub 出題(計算種類 As String) Application.ScreenUpdating = False Application.EnableEvents = False Dim QuestionNo As Long QuestionNo = wsCalc.Range("解答数").Value Call 解答履歴転記 '設定問題数をクリアしたときの処理 If QuestionNo = wsCalc.Range("問題数").Value Then MsgBox "全問終了しました!", vbInformation + vbOKOnly, "筆算マラソン終了" wsCalc.Unprotect wsCalc.CommandButton1.Enabled = True Range("解答中").Value = "" Range("解答数").Value = "" GoTo num1 End If '###出題処理 Dim UeMax As Long Dim UeMin As Long Dim SitaMax As Long Dim SitaMin As Long With wsCalc UeMax = .Range("上段最大値").Value UeMin = .Range("上段最小値").Value SitaMax = .Range("下段最大値").Value SitaMin = .Range("下段最小値").Value End With 'それぞれの出題ロジックから上の段・下の段の出題数値を配列で受取る Dim 出題 As Variant Select Case 計算種類 Case "たしざん" 出題 = 足し算(SitaMin, SitaMax, UeMin, UeMax) Case "ひきざん" 出題 = 引き算(SitaMin, SitaMax, UeMin, UeMax) Case "かけざん" 出題 = 掛け算(SitaMin, SitaMax, UeMin, UeMax) End Select '上記で作成した問題数値をセルに転記 With wsCalc .Unprotect .Range("解答").Value = "" .Range("上段出題").Value = 出題(0) .Range("下段出題").Value = 出題(1) .Range("解答数").Value = .Range("解答数").Value + 1 .Protect End With num1: Application.EnableEvents = True Application.ScreenUpdating = True End Sub '--------------------------------------------------------------------------- Private Function 足し算(下段最小値 As Long, 下段最大値 As Long, 上段最小値 As Long, 上段最大値 As Long) As Variant Dim UeQuestion As Long Dim SitaQuestion As Long UeQuestion = Fix(Rnd() * (上段最大値 - 上段最小値 + 1)) + 上段最小値 SitaQuestion = Fix(Rnd() * (下段最大値 - 下段最小値 + 1)) + 下段最小値 足し算 = Array(UeQuestion, SitaQuestion) End Function '--------------------------------------------------------------------------- Private Function 引き算(下段最小値 As Long, 下段最大値 As Long, 上段最小値 As Long, 上段最大値 As Long) As Variant Dim UeQuestion As Long Dim SitaQuestion As Long UeQuestion = Fix(Rnd() * (上段最大値 - 上段最小値 + 1)) + 上段最小値 SitaQuestion = Fix(Rnd() * (下段最大値 - 下段最小値 + 1)) + 下段最小値 If wsCalc.Range("オプション").Value = "答えがマイナスにならないように出題" And SitaQuestion > UeQuestion Then Dim tmp As Long tmp = UeQuestion UeQuestion = SitaQuestion SitaQuestion = tmp End If 引き算 = Array(UeQuestion, SitaQuestion) End Function '--------------------------------------------------------------------------- Private Function 掛け算(下段最小値 As Long, 下段最大値 As Long, 上段最小値 As Long, 上段最大値 As Long) As Variant Dim UeQuestion As Long Dim SitaQuestion As Long UeQuestion = Fix(Rnd() * (上段最大値 - 上段最小値 + 1)) + 上段最小値 SitaQuestion = Fix(Rnd() * (下段最大値 - 下段最小値 + 1)) + 下段最小値 掛け算 = Array(UeQuestion, SitaQuestion) End Function '--------------------------------------------------------------------------- '###解答後の処理 Sub 解答履歴転記() Const AnsHistoryStratRow As Long = 4 Dim QuestionNo As Long With wsCalc QuestionNo = .Range("解答数").Value '解答履歴の転記 If QuestionNo >= 1 Then .Unprotect Dim AnsHistory As Variant '2問目以降の解答の場合解答履歴欄に記載されている履歴を1段下にずらす If QuestionNo >= 2 Then AnsHistory = .Range(Cells(AnsHistoryStratRow + 1, 14), Cells(AnsHistoryStratRow + QuestionNo - 1, 20)).Value .Cells(AnsHistoryStratRow + 2, 14).Resize(UBound(AnsHistory), UBound(AnsHistory, 2)).Value = AnsHistory End If .Cells(AnsHistoryStratRow + 1, 14).Value = QuestionNo .Cells(AnsHistoryStratRow + 1, 15).Value = .Range("上段出題").Value .Cells(AnsHistoryStratRow + 1, 16).Value = .Range("下段出題").Offset(, -1).Value .Cells(AnsHistoryStratRow + 1, 17).Value = .Range("下段出題").Value .Cells(AnsHistoryStratRow + 1, 18).Value = "=" .Cells(AnsHistoryStratRow + 1, 19).Value = .Range("解答").Value .Cells(AnsHistoryStratRow + 1, 20).Value = 正誤判定(.Range("計算種類").Value, .Range("上段出題").Value, _ .Range("下段出題").Value, .Range("解答").Value) .Protect End If End With End Sub '--------------------------------------------------------------------------- Private Function 正誤判定(計算種類 As String, 上段出題 As Long, 下段出題 As Long, 解答 As Variant) As String Dim tmp As Boolean tmp = False Select Case 計算種類 Case "たしざん" If 解答 = 上段出題 + 下段出題 Then tmp = True Case "ひきざん" If 解答 = 上段出題 - 下段出題 Then tmp = True Case "かけざん" If 解答 = 上段出題 * 下段出題 Then tmp = True End Select If tmp Then 正誤判定 = "○" Else 正誤判定 = "×" End If End Function
今回は関数名にも変数にも日本語を使いまくりました。
その方が読みやすい気がしたからです。
(こういうのを英語で表現する練習もしたほうが良い気もしますが
「出題」はスタートボタンを押した時と解答欄に入力されたときに使用されます。
解答履歴への転記・各種問題機能の呼び出しを担当しています。
「足し算」・「引き算」・「掛け算」はそれぞれ出題を担当しています。
引き算のみオプション対応が必要なため処理内容が異なっています。
現時点では足し算・掛け算は処理内容が同じですが、将来のオプション処理対応のため分けています。
それぞれの処理は返り値として上段の出題数・下段の出題数値を配列で返します。
解答履歴転記は
・問題番号
・出題の上の段の数字
・計算記号(+ー×)
・出題の下の段の数字
・解答
を履歴欄に転記していきます。
これは下にドンドン追加していくと最新の解答の正誤が画面外にいってしまって見えなくなるのを防ぐためです。
正誤判定は解答が正しいかどうかの判定を行っています。
まとめ
取り敢えずここまで作っておけばしばらくは大丈夫でしょう。
しかしまだまだ遠慮を知らない息子から、情け容赦無い改善要望が出るたびにブラッシュアップしていきたいと思います。