VBAの学校ドリルのプログラムを再掲する。
学校計算ドリル
Sub チェック()
Dim i As Long 'カウンタ変数 ※→「開発」→「マクロ」→「Module1」→「ツール」→「マクロ」→「チェック」→「編集」
Dim myTemporary As Long 'あまりの処理
Dim myAmari As Long
Dim myGANS As Long 'Counter Good Answer
Dim SRT_BS As Long 'Displacement Count Area
Dim ST_PTR As Long '生徒のラインナンバー
Dim myANSWR As Boolean '割り算の商と余りが両方あってなければいけない
' Code
myGANS = 0 'Initialize
myANSWR = False
Sheets("Sheet1").Select 'Select Sheet1
myOperator = Cells(1, 10).Value
For i = ORG_CLM To DST_CLM
'A列の値とC列の値の和がE列に入力された答えと正しいか判定
If myOperator = "+" Then
SRT_BS = 5
If Cells(i, NUM1_RW).Value + Cells(i, NUM2_RW).Value = Cells(i, ANSW_RW).Value Then
Cells(i, ANSW_RW).Font.Color = vbBlue '正解なら文字色を青に
myGANS = myGANS + 1
Else
Cells(i, ANSW_RW).Font.Color = vbRed '不正解なら文字色を赤に
End If
End If
If myOperator = "-" Then
SRT_BS = 10
If Cells(i, NUM1_RW).Value - Cells(i, NUM2_RW).Value = Cells(i, ANSW_RW).Value Then
Cells(i, ANSW_RW).Font.Color = vbBlue '正解なら文字色を青に
myGANS = myGANS + 1
Else
Cells(i, ANSW_RW).Font.Color = vbRed '不正解なら文字色を赤に
End If
End If
If myOperator = "*" Then
SRT_BS = 15
If Cells(i, NUM1_RW).Value * Cells(i, NUM2_RW).Value = Cells(i, ANSW_RW).Value Then
Cells(i, ANSW_RW).Font.Color = vbBlue '正解なら文字色を青に
myGANS = myGANS + 1
Else
Cells(i, ANSW_RW).Font.Color = vbRed '不正解なら文字色を赤に
End If
End If
If myOperator = "/" Then
SRT_BS = 20
If Int(Cells(i, NUM1_RW).Value / Cells(i, NUM2_RW).Value) = Cells(i, ANSW_RW).Value Then
Cells(i, ANSW_RW).Font.Color = vbBlue '正解なら文字色を青に
myANSWR = True
Else
Cells(i, ANSW_RW).Font.Color = vbRed '不正解なら文字色を赤に
End If
myTemporary = Int(Cells(i, NUM1_RW).Value / Cells(i, NUM2_RW).Value)
myAmari = Cells(i, NUM1_RW).Value - myTemporary * Cells(i, NUM2_RW).Value
If Cells(i, AMAR_RW).Value = myAmari Then
Cells(i, AMAR_RW).Font.Color = vbBlue
If myANSWR = True Then
myGANS = myGANS + 1
End If
Else
Cells(i, AMAR_RW).Font.Color = vbRed
End If
End If
Next i
If myGANS = SEIKAI_SU Then
MsgBox "全問正解です。おめでとう！"
Else
MsgBox "もうちょっと！"
End If
SRT_RW = Cells(1, 13).Value 'Bias Locate depend on 横 operator
Sheets("Sheet2").Select
SRT_BS = SRT_BS + SRT_RW 'Fix Count Location
ST_PTR = Cells(1, 14).Value 'Current 生徒の行
Cells(1, 15).Value = SRT_BS '横のLocation
Cells(ST_PTR, SRT_BS) = myGANS '正解数を入れる
Sheets("Sheet1").Select 'Change Manage Page To Question Page
End Sub
Sub リセット()
Dim i As Long 'カウンタ変数
Dim myTemporary As Long
UserForm3.Show 'Show List2
Sheets("Sheet2").Select 'Select Sheet2
If IsNumeric(Cells(1, 11).Value) Then
' MsgBox "True"
If Cells(1, 11).Value = 0 Then
ST_NUM = 4
Cells(1, 11).Value = ST_NUM
Else
ST_NUM = Cells(1, 11).Value '前回からの登録簿のスタート値を使用
'MsgBox ST_NUM
End If
Else
ST_NUM = 4 '生徒ライン番号初期化
Cells(1, 11).Value = ST_NUM '生徒ライン番号初期化
MsgBox ST_NUM 'for debug
End If
If MsgBox("追加登録しますか？", vbYesNo) = vbYes Then '追加登録をするか？
Do While Cells(1, 12).Value <> "End" '後でENDをセットするルーチンを作る事
If Cells(1, 12).Value = "End" Then '登録作業エンド
Sheets("Sheet2").Select 'Select Sheet2
End If
Cells(1, 10).Value = "Error" 'Error Flag On?
Do While Cells(1, 10).Value = "Error"
FRM_USER.Show 'User Form Show Registry ID
Loop
Cells(1, 10).ClearContents 'Error Flag On?
Loop 'New Loop End
Else
MsgBox "今回は登録しません。"
Sheets("Sheet2").Select
Cells(1, 12).Value = "End"
End If
'問題出題
Sheets("Sheet2").Select 'Servey Loop End
If Cells(1, 12).Value = "End" Then
Cells(1, 12).ClearContents 'For debug
Sheets("Sheet1").Select 'Select Sheet1
UserForm1.Show 'UserForm1 Show 加減乗除
UserForm2.Show '桁数セット
End If
Sheets("Sheet1").Select 'Select Sheet1
myBias = Cells(1, 11).Value 'WorkCell for Bias Value
myOperator = Cells(1, 10).Value 'Workarea for Operator
For i = ORG_CLM To DST_CLM
Cells(i, ANSW_RW).ClearContents '値をクリア
Cells(i, AMAR_RW).ClearContents
Cells(i, ANSW_RW).Font.Color = vbBlack '文字色を黒に
Cells(i, AMAR_RW).Font.Color = vbBlack
Cells(i, NUM1_RW).Value = Int(Rnd * myBias) 'A列に１桁～４桁のランダムな数値を入力
Cells(i, OPR_RW).Value = myOperator '四則演算子を入れる
Cells(i, NUM2_RW).Value = Int(Rnd * myBias) 'Ａ列に１桁～４桁のランダムな数値を入力
If myOperator = "-" Then
myTemporary = Cells(i, NUM1_RW)
If Cells(i, NUM1_RW) < Cells(i, NUM2_RW) Then
Cells(i, NUM1_RW) = Cells(i, NUM2_RW)
Cells(i, NUM2_RW) = myTemporary
End If
End If
If myOperator = "/" Then
myTemporary = Cells(i, NUM1_RW)
If Cells(i, NUM1_RW) < Cells(i, NUM2_RW) Then
Cells(i, NUM1_RW) = Cells(i, NUM2_RW)
Cells(i, NUM2_RW) = myTemporary
If Cells(i, NUM2_RW) = 0 Then 'Escape 0 devide
Cells(i, NUM2_RW) = 1
End If
Else
If Cells(i, NUM2_RW) = 0 Then 'Escape 0 devide
Cells(i, NUM2_RW) = 1
End If
End If
End If
Next i
End Sub
Option Explicit
Dim strMSG As String
Public ST_NUM As Long
Private Sub TextBox2_Change()
MsgBox "Box2"
Unload Me
End Sub
Private Sub TextBox3_Change()
MsgBox "Box3"
Unload Me
End Sub
Private Sub FRM_USER()
MsgBox "FRM_USER()"
Unload Me
End Sub
Private Sub CMD_OK_Click() 'UserForm_Click()
'MsgBox "Execute _Click() on Registry"
Sheets("Sheet2").Select 'Select Sheet2
If OptionButton1.Value = True Then '登録終了
Cells(1, 12).Value = "End"
End If
If OptionButton2.Value = True Then
Cells(1, 12).ClearContents
End If
If OptionButton3.Value = True Then
Cells(1, 13).Value = "指定" 'Fix Row
End If
'入力内容のチェック
If Trim$(TXT_NAME.Text) = "" Then
strMSG = "氏名が入力されていません。"
ElseIf Trim$(TXT_CODE.Text) = "" Then
strMSG = "生徒Noが入力されていません。"
ElseIf Trim$(TXT_SCLNM.Text) = "" Then
strMSG = "学校名が入力されていません。"
ElseIf IsNumeric(Trim$(TXT_CODE.Text)) <> True Then
strMSG = "生徒Noが数字ではありません。"
ElseIf Len(Trim$(TXT_CODE.Text)) <> 5 Then
strMSG = "生徒Noは5桁で入力してください。"
ElseIf Trim$(TXT_CODE.Text) < 10000 Then
strMSG = "生徒Noは10000以上で入力してください。"
End If
Sheets("Sheet2").Select 'Select Sheet2
If Trim$(strMSG) <> "" Then
Cells(1, 10).Value = "Error" 'Set Error Flag
MsgBox strMSG
Else
Cells(1, 10).ClearContents 'Clear Error Flag
ST_NUM = Cells(1, 11).Value '生徒の番号をセット
Cells(ST_NUM, 1).Value = Trim$(TXT_NAME.Text) '氏名
Cells(ST_NUM, 2).Value = Trim$(TXT_CODE.Text) '生徒No
Cells(ST_NUM, 3).Value = Trim$(TXT_SCLNM.Text) '学校名
ST_NUM = ST_NUM + 1 'Sheet2の行No
Cells(1, 11).Value = ST_NUM 'Save 生徒No
End If
Unload Me
End Sub
Option Explicit
Private Sub CommandButton1_Click()
ListBox1.RowSource = "Sheet2!A4:A103" 'Set List
'Unload Me
End Sub
Private Sub ListBox1_Click()
'MsgBox Cells(ListBox1.ListIndex + 1, 1) 'Display ST_NUM 生徒No
'MsgBox ListBox1.ListIndex 'Line No. ST_PTR - 4
Sheets("Sheet2").Select
Cells(1, 14).Value = ListBox1.ListIndex + 4
'MsgBox ListBox1.ListIndex + 4 'Line NO. ST_PTR
End Sub
Option Explicit
Dim strMSG As String
Public ST_NUM As Long
Private Sub TextBox2_Change()
MsgBox "Box2"
Unload Me
End Sub
Private Sub TextBox3_Change()
MsgBox "Box3"
Unload Me
End Sub
Private Sub FRM_USER()
MsgBox "FRM_USER()"
Unload Me
End Sub
Private Sub CMD_OK_Click() 'UserForm_Click()
'MsgBox "Execute _Click() on Registry"
Sheets("Sheet2").Select 'Select Sheet2
If OptionButton1.Value = True Then '登録終了
Cells(1, 12).Value = "End"
End If
If OptionButton2.Value = True Then
Cells(1, 12).ClearContents
End If
If OptionButton3.Value = True Then
Cells(1, 13).Value = "指定" 'Fix Row
End If
'入力内容のチェック
If Trim$(TXT_NAME.Text) = "" Then
strMSG = "氏名が入力されていません。"
ElseIf Trim$(TXT_CODE.Text) = "" Then
strMSG = "生徒Noが入力されていません。"
ElseIf Trim$(TXT_SCLNM.Text) = "" Then
strMSG = "学校名が入力されていません。"
ElseIf IsNumeric(Trim$(TXT_CODE.Text)) <> True Then
strMSG = "生徒Noが数字ではありません。"
ElseIf Len(Trim$(TXT_CODE.Text)) <> 5 Then
strMSG = "生徒Noは5桁で入力してください。"
ElseIf Trim$(TXT_CODE.Text) < 10000 Then
strMSG = "生徒Noは10000以上で入力してください。"
End If
Sheets("Sheet2").Select 'Select Sheet2
If Trim$(strMSG) <> "" Then
Cells(1, 10).Value = "Error" 'Set Error Flag
MsgBox strMSG
Else
Cells(1, 10).ClearContents 'Clear Error Flag
ST_NUM = Cells(1, 11).Value '生徒の番号をセット
Cells(ST_NUM, 1).Value = Trim$(TXT_NAME.Text) '氏名
Cells(ST_NUM, 2).Value = Trim$(TXT_CODE.Text) '生徒No
Cells(ST_NUM, 3).Value = Trim$(TXT_SCLNM.Text) '学校名
ST_NUM = ST_NUM + 1 'Sheet2の行No
Cells(1, 11).Value = ST_NUM 'Save 生徒No
End If
Unload Me
End Sub
Option Explicit
Public myOperator As String
Const OPR_RW As Integer = 2
Private Sub CommandButton1_Click() 'UserForm_Click()
Sheets("Sheet1").Select 'Select Sheet1
If OptionButton1.Value = True Then
myOperator = "+"
End If
If OptionButton2.Value = True Then
myOperator = "-"
End If
If OptionButton3.Value = True Then
myOperator = "*"
End If
If OptionButton4.Value = True Then
myOperator = "/"
End If
'MsgBox myOperator
Cells(1, 10).Value = myOperator 'Save Operator as String
Unload Me
End Sub
'Private Sub UserForm_Click()
' 'UserForm.Show
' MsgBox "Before CommandButton1"
'End Sub
Private Sub UserForm_Click()
End Sub
Option Explicit
Public myBias As Long
Public SRT_RW As Long
Private Sub CommandButton1_Click() 'UserForm_Click()
Sheets("Sheet1").Select 'Select Sheet1
SRT_RW = 0 'Initialize Operator Bias Location
'MsgBox "Before CommandButton1"
If OptionButton1.Value = True Then '1桁
myBias = 10
SRT_RW = SRT_RW + 0
End If
If OptionButton2.Value = True Then '2桁
myBias = 100
SRT_RW = SRT_RW + 1
End If
If OptionButton3.Value = True Then '3桁
myBias = 1000
SRT_RW = SRT_RW + 2
End If
If OptionButton4.Value = True Then '4桁
myBias = 10000
SRT_RW = SRT_RW + 3
End If
'MsgBox myBias
Cells(1, 11).Value = myBias 'Save 桁数
Cells(1, 13).Value = SRT_RW
Unload Me
End Sub
'Private Sub UserForm_Click()
' MsgBox "Here is UserForm2"
'UserForm2.Show
'End Sub
Private Sub UserForm_Click()
End Sub
Option Explicit
Private Sub CommandButton1_Click()
ListBox1.RowSource = "Sheet2!A4:A103" 'Set List
'Unload Me
End Sub
Private Sub ListBox1_Click()
'MsgBox Cells(ListBox1.ListIndex + 1, 1) 'Display ST_NUM 生徒No
'MsgBox ListBox1.ListIndex 'Line No. ST_PTR - 4
Sheets("Sheet2").Select
Cells(1, 14).Value = ListBox1.ListIndex + 4
'MsgBox ListBox1.ListIndex + 4 'Line NO. ST_PTR
End Sub
上記プログラムはかつて2度ほど当ブログにUPしたことがあった。
↑人気ブログランキングに参加しています。ポチっと１票を！
