先日作成したこちらの筆算の学習ツール。
www.excellovers.com
足し算・引き算・掛け算までは出来ていたのですが、勢いに任せて割り算対応もしてみました。
その過程でクライアント(嫁)から次々と要望が出てきましたが、何とか全て対応いたしました。
その時の応酬はこちら。
俺「割り算の筆算はコレでどうだ!」
— Kou Excelが大好きだ! (@LoverExcel) 2019年4月29日
嫁「おぉ~すごい!」
俺「(フフ~ン)」
嫁「後はその問題を文章で表示してくれたらいいかなぁ」
俺「(;´Д`)」 pic.twitter.com/V2PYVE0RFk
俺「問題の文章表示できるようにした!」
— Kou Excelが大好きだ! (@LoverExcel) 2019年4月29日
嫁「おぉ~すごい!」
俺「(( ・´ー・`)どや)」
嫁「足し算も引き算も掛け算もやったの?割り算だけでよかったのに」
俺「・・・((´・ω・`)ショボーン)」
事前のヒアリングはしっかりしましょう。 pic.twitter.com/2wNiB7aixa
余談はコレくらいにして、本題に移ります。
完成品
こちらが完成品の操作画面です。
足し算(及び引き算・割り算)
割り算(文章問題表示)
コード
wsCalcワークシート
Option Explicit 'スタートボタン 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("計算記号").Value = "+" 割り算以外表示リセット Case "ひきざん" .Range("計算記号").Value = "ー" 割り算以外表示リセット Case "かけざん" .Range("計算記号").Value = "×" 割り算以外表示リセット Case "わりざん" .Range("計算記号").Value = "" .Range("計算記号").Offset(1).Value = "あまり" .Range("商").Locked = False .Range("商").Activate .Range("商").Borders(xlEdgeBottom).LineStyle = xlContinuous .Range("商").Borders(xlEdgeBottom).Weight = xlMedium Shapes("Arc 1").Line.ForeColor.RGB = RGB(0, 0, 0) 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) If Target.Address = Range("解答").Address And wsCalc.Range("計算種類") = "わりざん" And wsCalc.Range("解答中").Value = 1 Then wsCalc.Range("商").Activate 出題 wsCalc.Range("計算種類").Value ElseIf Target.Address = Range("解答").Address And wsCalc.Range("解答中").Value = 1 Then wsCalc.Range("解答").Activate 出題 wsCalc.Range("計算種類").Value ElseIf Target.Address = Range("計算種類").Address Then If Range("計算種類").Value = "わりざん" Then Range("オプション").Value = "商と余りで解答" ElseIf Range("計算種類").Value = "ひきざん" Then Range("オプション").Value = "答えがマイナスにならないように出題" Else Range("オプション").Value = "" End If 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 '---------------------------------------------- Private Sub 割り算以外表示リセット() With wsCalc .Range("計算記号").Offset(2).Value = "" .Range("計算記号").Offset(1).Value = "" .Range("商").Borders(xlEdgeBottom).LineStyle = xlNone .Range("商").Locked = True Shapes("Arc 1").Line.ForeColor.RGB = RGB(255, 255, 255) End With End Sub
割り算のみ他の四則演算と筆算の形式が違うため、一気に対応が複雑化しました。
①割り算なしの場合は計算記号(+、ー、×)の調整のみで済んだことが、そもそも筆算の表示が割り算のみ異なっているため、別の対応が必要になりました。
・解答入力セルが1ヶ所だったのが2ヶ所に増加。
・計算記号の表示位置、表示方法が異なる。
1つ目に関しては商の部分のセルの保護を割り算のときのみ解除することで対応
2つ目に関しては罫線の追加とオートシェイプの塗り潰しの有無で対応
標準モジュール
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) Case "わりざん" 出題 = 割り算(SitaMin, SitaMax, UeMin, UeMax) Case Else MsgBox "計算種類が正しく選択されていません", vbCritical + vbOKOnly, "選択エラー" GoTo num1 End Select '①文章問題の作成 Dim QuestionStr As String Select Case 計算種類 Case "たしざん" QuestionStr = "グミを『" & 出題(0) & "こ』もっています。" & vbCrLf & vbCrLf & "おかあさんが『" & 出題(1) & "こ』くれました。" & vbCrLf & vbCrLf & "ぜんぶでなんこもってるでしょうか?" Case "ひきざん" QuestionStr = "グミを『" & 出題(0) & "こ』もっています。" & vbCrLf & vbCrLf & "おかあさんに『" & 出題(1) & "こ』あげました。" & vbCrLf & vbCrLf & "ぜんぶでなんこもってるでしょうか?" Case "かけざん" QuestionStr = "グミを『" & 出題(0) & "にん』が" & vbCrLf & vbCrLf & "『" & 出題(1) & "こ』ずつもっています。" & vbCrLf & vbCrLf & "ぜんぶでなんこもってるでしょうか?" Case "わりざん" QuestionStr = "グミ『" & 出題(0) & "こ』を" & vbCrLf & vbCrLf & "『" & 出題(1) & "にん』でわけわけしました。" & vbCrLf & vbCrLf & "ひとりがなんこもっていて" & vbCrLf & vbCrLf & "なんこあまったでしょうか?" Case Else End Select '上記で作成した問題数値をセルに転記 With wsCalc .Unprotect .Range("H9").Comment.Text QuestionStr .Range("解答").Value = "" .Range("商").Value = "" .Range("商下段出題").Value = "" .Range("下段出題").Value = "" .Range("上段出題").Value = 出題(0) If .Range("計算種類").Value = "わりざん" Then .Range("商下段出題").Value = 出題(1) Else .Range("下段出題").Value = 出題(1) End If .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 '---------------------------------------------- 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, 21)).Value .Cells(AnsHistoryStratRow + 2, 14).Resize(UBound(AnsHistory), UBound(AnsHistory, 2)).Value = AnsHistory End If Dim UeQuestion As Long Dim SitaQuestion As Long Dim Answer As Long Dim DivisionMod As Variant Dim MathematicalSymbols As String ’②割り算の余り追加への対応 UeQuestion = .Range("上段出題").Value If .Range("計算種類").Value = "わりざん" Then SitaQuestion = .Range("商下段出題").Value Answer = .Range("商").Value DivisionMod = .Range("解答").Value MathematicalSymbols = "÷" Else SitaQuestion = .Range("下段出題").Value Answer = .Range("解答").Value MathematicalSymbols = .Range("計算記号").Value End If .Cells(AnsHistoryStratRow + 1, 14).Value = QuestionNo .Cells(AnsHistoryStratRow + 1, 15).Value = UeQuestion .Cells(AnsHistoryStratRow + 1, 16).Value = MathematicalSymbols .Cells(AnsHistoryStratRow + 1, 17).Value = SitaQuestion .Cells(AnsHistoryStratRow + 1, 18).Value = "=" .Cells(AnsHistoryStratRow + 1, 19).Value = Answer .Cells(AnsHistoryStratRow + 1, 20).Value = DivisionMod .Cells(AnsHistoryStratRow + 1, 21).Value = 正誤判定(.Range("計算種類").Value, UeQuestion, _ SitaQuestion, Answer, DivisionMod) .Protect End If End With End Sub '---------------------------------------------- Private Function 正誤判定(計算種類 As String, 上段出題 As Long, 下段出題 As Long, 解答 As Variant, Optional 解答余り 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 Case "わりざん" If wsCalc.Range("オプション").Value = "商と余りで解答" Then Dim 商 As Long Dim 余 As Long 商 = 上段出題 \ 下段出題 余 = 上段出題 Mod 下段出題 If 解答 = 商 And 余 = 解答余り Then tmp = True Else If 解答 = 上段出題 / 下段出題 Then tmp = True End If End Select If tmp Then 正誤判定 = "○" Else 正誤判定 = "×" End If End Function
標準モジュール側も割り算追加の影響で複雑化しています。
①想定外の内容ですが、クライアント(嫁)の要望で追加しました。計算種類によって文言を変えるようにしました。ベースが出来たのでそれぞれの計算についてレパートリーを増やすことも可能です。
②列の追加と「正誤判定」関数内に割り算の対応を追加しました。
まとめ
現時点では割り算は商と余りで表現する解答にしか対応していません。
ただこの方式で解答する以上は小数点以下の解答に対応する必要はないのかもしれませんが。
今後のクライアント(嫁、息子)の依頼次第といったところです。
これで小学校4年生くらいまでは使えるのかな。