前回作成したエクセルでの確認テスト作成機能に新たな内容を追加してみました。
出題範囲選択機能を追加
出題範囲を選択するにチェックすると入力ボックスが現れます。
追加したコードとしてチェックボックス2がチェックされている場合出題範囲を入力する為のインプットボックスを出して入力した範囲にプロラムを起動します。
If CheckBox2.Value = True Then
Dim ans1 As String
Dim ans2 As String
ans1 = InputBox(“出題範囲の選択・出題始めのNoを入力してください”)
If ans1 > b Then
MsgBox “出題Noに誤りがあります。”
End
ElseIf ans1 = “” Then
ans1 = 1
Else
End If
ans2 = InputBox(“出題範囲の選択・出題終わりのNoを入力してください”)
If ans1 > ans1 Then
MsgBox “出題Noに誤りがあります。”
End
ElseIf ans2 = “” Then
and2 = b
Else
End If
ans1 = ans1 + 1
b = ans2 + 1
Else
ans1 = 2
End If
使用したVBAはIF文とINPUTBOXです。
①IF文を使用し「もしチェックボックス2」がTrueならINPUTBOXを表示して出題範囲に入力を促しなさいとしもしINPUTBOXへの入力が無ければ終了しなさいとしています。
If～の基本的な構成
If構成分はVBAマクロを作成する上で最も使用頻度が高い重要なプログラムですのでしっかり覚えましょう。
if 条件式 Then
条件式を満たした場合の処理
「条件式」CheckBox2.Value = True ・・・・・チェックボックス2がTrue
「条件を満たした場合の処理」ans1 = InputBox(“出題範囲の選択・出題始めのNoを入力してください”)・・・・INPUTBOXで入力されたデータをans1としなさい
という処理
またはElseに後に記載して条件式を満たさない場合の処理を記載しすることで条件を満たさない場合にも処理する事が出来るようになります。処理終わりにはIfが終了したことを記すためEndIfでを処理を終了します。
If 条件式 Then
条件式を満たした場合の処理
Else
条件式を満たさない場合の処理
End If
Else構成分をElseIfにする事で新たな条件式を追加する事ができます。
ElseIf 条件式 Then
INPUTBOXの基本的な構成
InputBox(prompt[, title] [, default] [, xpos] [, ypos] )
- prompt （入力必須）: ユーザー対してメッセージを表示する内容を記載します。
今回は「”出題範囲の選択・出題始めのNoを入力してください”」とユーザーに対して出題範囲を入力する様にコメントしています。特に設定は必要なく使用出来るためEXCELでVBAプログラムを使ってマクロを起動させる場合には重宝します。 - title（入力なしでもOK）:Tには 入力ボックスのタイトルを記載します。入力しなくても普通に機能します。
上記のプログラムにInputBox(“出題範囲の選択・出題始めのNoを入力してください”, “範囲入力”)
「,”入力範囲”」を追加する事でタイトル入力範囲を表示しています。 - default （入力なしでもOK）: ユーザーが入力する値の初期値を表す文字列です。省略した場合、空の文字列が初期値として表示されます。
- xpos（入力なしでもOK）: ダイアログボックスの表示位置Xを指定します。省略した場合、中央に表示されます。
- Ypos（入力なしでもOK）: ダイアログボックスの表示位置Y位置を指定します。省略した場合、上から1/3の位置にに表示されます。
INPUTBOXはEXCELマクロを使用する場合重宝する機能ですので覚えておきましょう。
答え合わせ機能の追加
オプションボタンで和訳と英記を選択して開始ボタンをクリックする事で自動で答え合わせを行います。
現在開いているシートと同じデータの答えを探してデータの一致と不一致を自動的にチェックして、該当セルをピンク色に着色し、不正解情報を記録します。最後には正答率も表記されます。
和訳は、文字データをフリガナ（ふりがな）を取得して比較して判断します。日本語の文字列の一致をふりがなで検証す為漢字回答でもひらがな回答でもカタカナ回答でも判断可能です。英記に関しては大文字・小文字識別なしで判断します。
違いを確認してみよう
Sub 和訳答え合わせ()
Dim a, b, c, Nam, NamQ, Na, N1, N2
Dim e1, e2, f, f1, f2
Dim activeSheet As Worksheet
Set activeSheet = ActiveWorkbook.activeSheet
Dim sheetName As String
sheetName = activeSheet.Name
Nam = sheetName
NamQ = Nam + "Q"
Na = Mid(Nam, 5)a = Sheets(Nam).Cells(Rows.Count, 2).End(xlUp).Row + 1 ‘データ数の取得
b = 2
c = Sheets(Na).Cells(Rows.Count, 2).End(xlUp).Row ‘データ数の取得
f1 = 0
f2 = 0
For b = 2 To a
Dim string1 As String
Dim string2 As String
Dim string3 As String
Dim string4 As String
Dim result As Integer
Dim result1 As Integer
string1 = Trim(Sheets(Nam).Cells(b, 3).Value)
string2 = Trim(Sheets(NamQ).Cells(b, 3).Value)
string3 = Trim(Sheets(Nam).Cells(b, 6).Value)
string4 = Trim(Sheets(NamQ).Cells(b, 6).Value)
N1 = Trim(Sheets(Nam).Cells(b, 4).Value)
N2 = Trim(Sheets(Nam).Cells(b, 1).Value)
result = StrComp(Application.GetPhonetic(string1), Application.GetPhonetic(string2), vbBinaryCompare)
result1 = StrComp(Application.GetPhonetic(string3), Application.GetPhonetic(string4), vbBinaryCompare)If result <> 0 Then
‘Sheets(Nam).Cells(b, 1).Interior.ColorIndex = 38 ‘ ピンク
Sheets(Nam).Cells(b, 3).Interior.ColorIndex = 38 ‘ ピンク
e1 = Sheets(Nam).Cells(b, 1)
f2 = f2 + 1
d = 2
Do While d < c
If Sheets(Na).Cells(d, 1) = e1 Then
Sheets(Na).Cells(d, 8) = “TRUE”
Else
End If
d = d + 1
Loop
ElseIf N2 = “” Then
GoTo y
Else
f1 = f1 + 1
End If
y:
If result1 <> 0 Then
‘Sheets(Nam).Cells(b, 4).Interior.ColorIndex = 38 ‘ ピンク
Sheets(Nam).Cells(b, 6).Interior.ColorIndex = 38 ‘ ピンク
e2 = Sheets(Nam).Cells(b, 4)
f2 = f2 + 1
d = 2
Do While d < c
If Sheets(Na).Cells(d, 1) = e2 Then
Sheets(Na).Cells(d, 8) = “TRUE”
Else
End If
d = d + 1
Loop
ElseIf N1 = “” Then
GoTo z
Else
f1 = f1 + 1
End If
z:
Next b
f = f1 + f2
‘Unload UserForm3
MsgBox f & “問中_” & f2 & “問不正解です”
‘MsgBox f2
‘Unload UserForm3
End Sub
Sub 英記答え合わせ()
Dim a, b, c, Nam, NamQ, Na, N1, N2
Dim e1, e2, f, f1, f2
Dim activeSheet As Worksheet
Set activeSheet = ActiveWorkbook.activeSheet
Dim sheetName As String
sheetName = activeSheet.Name
Nam = sheetName
NamQ = Nam + "Q"
Na = Mid(Nam, 5)a = Sheets(Nam).Cells(Rows.Count, 2).End(xlUp).Row + 1 ‘データ数の取得
b = 2
c = Sheets(Na).Cells(Rows.Count, 2).End(xlUp).Row ‘データ数の取得
f1 = 0
f2 = 0
For b = 2 To a
Dim string1 As String
Dim string2 As String
Dim string3 As String
Dim string4 As String
Dim result As Integer
Dim result1 As Integer
string1 = Trim(Sheets(Nam).Cells(b, 3).Value)
string2 = Trim(Sheets(NamQ).Cells(b, 3).Value)
string3 = Trim(Sheets(Nam).Cells(b, 6).Value)
string4 = Trim(Sheets(NamQ).Cells(b, 6).Value)
N1 = Trim(Sheets(Nam).Cells(b, 4).Value)
N2 = Trim(Sheets(Nam).Cells(b, 1).Value)
result = StrComp(string1, string2, vbTextCompare)
result1 = StrComp(string3, string4, vbTextCompare)If result <> 0 Then
‘Sheets(Nam).Cells(b, 1).Interior.ColorIndex = 38 ‘ ピンク
Sheets(Nam).Cells(b, 3).Interior.ColorIndex = 38 ‘ ピンク
e1 = Sheets(Nam).Cells(b, 1)
f2 = f2 + 1
d = 2
Do While d < c
If Sheets(Na).Cells(d, 1) = e1 Then
Sheets(Na).Cells(d, 8) = “TRUE”
Else
End If
d = d + 1
Loop
ElseIf N2 = “” Then
GoTo y
Else
f1 = f1 + 1
End If
y:
If result1 <> 0 Then
‘Sheets(Nam).Cells(b, 4).Interior.ColorIndex = 38 ‘ ピンク
Sheets(Nam).Cells(b, 6).Interior.ColorIndex = 38 ‘ ピンク
e2 = Sheets(Nam).Cells(b, 4)
f2 = f2 + 1
d = 2
Do While d < c
If Sheets(Na).Cells(d, 1) = e2 Then
Sheets(Na).Cells(d, 8) = “TRUE”
Else
End If
d = d + 1
Loop
ElseIf N1 = “” Then
GoTo z
Else
f1 = f1 + 1
End If
z:
Next b
f = f1 + f2
MsgBox f & “問中_” & f2 & “問不正解です”
‘MsgBox f2
End Sub
ワンポイント
和訳の答え合わせはApplication.GetPhonetic関数を使用しています。GetPhonetic関数は、指定された文字列のフリガナ（ふりがな）を返すExcelの組み込み関数です。ふりかな変換することで漢字とひらがな・カタカナの比較ができるようになります。ちょっとした違いですが日本語を比較する場合にはとても有効です。
コメント