英語の勉強のために、英文の穴埋め問題を自動で作成するマクロを作ったので紹介する。
なお、ここでいう穴埋め問題とは全単語の頭文字だけ残して他が空欄の問題を指し、よくある一単語だけが空欄の穴埋め問題とは別物であるので注意。
サンプル
今回使うサンプルは下記ボタンから入手可能である。
マクロ本体「英文穴埋め問題自動作成_サンプル.xlsm」を開くと、下のようなウィンドウが表示される。
「開始」セルに最初の番号を、「終了」セルに最後の番号を入力し、「問題作成」ボタンを押すと、下図のように指定した範囲で頭文字以外のアルファベットが全てアンダーバーに置換された穴埋め問題を自動で作成する。
(下図では全範囲を指定しているが、開始番号3、終了番号8のような部分指定も可能である。)
「リセット」ボタンを押すと、問題作成前の状態に戻る。
コード詳説
「英文穴埋め問題自動作成_サンプル.xlsm」には2つのマクロが保存されている。
問題作成
穴埋め問題を作成する「問題作成」マクロの中身は下記のようになっている。
Sub 問題作成()
Dim i As Long
Dim k As Long
Dim l As Long
Dim m As Long
Dim mojisuu As Long
Dim start As Long
Dim goal As Long
start = ActiveSheet.Cells(3, 6).Value + 1
goal = ActiveSheet.Cells(5, 6).Value + 1
For m = start To goal
l = 2
ActiveSheet.Cells(m, 7).Value = ActiveSheet.Cells(m, 3).Value
mojisuu = Len(ActiveSheet.Cells(m, 7).Value)
For i = 2 To mojisuu
If Mid(ActiveSheet.Cells(m, 7).Value, i, 1) = " " Or i = mojisuu Then
For k = l To i - 1
ActiveSheet.Cells(m, 7).Value _
= Left(ActiveSheet.Cells(m, 7).Value, k - 1) _
& Replace(ActiveSheet.Cells(m, 7).Value, Mid(ActiveSheet.Cells(m, 7).Value, k, 1), "_", k, 1)
Next
l = i + 2
End If
Next
If Mid(ActiveSheet.Cells(m, 7).Value, mojisuu, 1) <> "." _
And Mid(ActiveSheet.Cells(m, 7).Value, mojisuu, 1) <> "?" _
And Mid(ActiveSheet.Cells(m, 7).Value, mojisuu - 1, 1) <> " " Then
ActiveSheet.Cells(m, 7).Value _
= Left(ActiveSheet.Cells(m, 7).Value, mojisuu - 1) _
& Replace(ActiveSheet.Cells(m, 7).Value, Mid(ActiveSheet.Cells(m, 7).Value, mojisuu, 1), "_", mojisuu, 1)
End If
ActiveSheet.Cells(m, 2).Value = ActiveSheet.Cells(m, 2).Value & vbLf & ActiveSheet.Cells(m, 7).Value
ActiveSheet.Cells(m, 7).Value = ""
Next
End Sub
まずは
start = ActiveSheet.Cells(3, 6).Value + 1
goal = ActiveSheet.Cells(5, 6).Value + 1
For m = start To goalで作成する問題番号をセルの行番号に変換し、指定した問題数だけFor文でループする処理の開始を宣言する。
l = 2は英文の内アンダーバーにする「最初の」アルファベットの位置を代入する変数である。
最初は2番目のアルファベットからアンダーバーにするため「2」を代入しておく。
ActiveSheet.Cells(m, 7).Value = ActiveSheet.Cells(m, 3).Value
mojisuu = Len(ActiveSheet.Cells(m, 7).Value)で英文を編集用セルにコピーし、英文の文字数を「mojisuu」に代入する。
For i = 2 To mojisuu
If Mid(ActiveSheet.Cells(m, 7).Value, i, 1) = " " Or i = mojisuu Then ここからアルファベットのアンダーバー変換処理の開始である。
英文の左から文字の種類を確認し、文字が半角スペースもしくは最後の文字に到達した場合で条件分岐する。
For k = l To i - 1
ActiveSheet.Cells(m, 7).Value _
= Left(ActiveSheet.Cells(m, 7).Value, k - 1) _
& Replace(ActiveSheet.Cells(m, 7).Value, Mid(ActiveSheet.Cells(m, 7).Value, k, 1), "_", k, 1)
Next
l = i + 2 条件を満たした場合、アンダーバーにすべきは頭文字と半角スペースの間にあるアルファベットである。
よって頭文字の次の文字(l番目)から半角スペースの前の文字(i-1番目)の範囲で、For文でアンダーバーに変換する。
変換部分は大分ややこしいが、これはReplace関数に起因している。
Replace関数で検索開始位置を指定すると、返り値ではその位置以前の文字列が消えてしまう。
(今回の場合はk番目以前の文字列が消えてしまう。)
よってこの消えてしまう文字列を補うために、Left関数でk番目以前の文字列を最初に抜き出しておき、両者を接続して穴埋め問題を作成している。
一通りアンダーバーに変換した後は、lに次の変換開始位置番号を代入しておく。
次の変換開始位置は次の単語の2番目の文字であるため、半角スペース(今のiの位置)から2つ目となりl=i+2となる。
これを実行すると、英文の中で各単語の頭文字、半角スペース、最後尾の文字以外は全てアンダーバーに変換される。
しかし、イディオムなど最後尾の文字がアルファベットで終わるものを問題にする場合は、上記のままだと最後尾のアルファベットが残ってしまい、不完全な穴埋め問題になる。
そこで、最後尾がアルファベットの場合は最後尾の文字もアンダーバーに変換するコードを追記する。
条件は下記の通りとする。
If Mid(ActiveSheet.Cells(m, 7).Value, mojisuu, 1) <> "." _
And Mid(ActiveSheet.Cells(m, 7).Value, mojisuu, 1) <> "?" _
And Mid(ActiveSheet.Cells(m, 7).Value, mojisuu - 1, 1) <> " " Thenすなわち最後尾の文字がコンマでないかつ、最後尾の文字が疑問符でないかつ、最後尾の直前の文字が半角スペースでない場合は、最後尾もアンダーバーにする。
最後尾の直前の文字が半角スペースの場合は、最後尾に記号としてのアルファベットが来ることを想定しており、これはアンダーバーに変換する必要はない。
この条件で
ActiveSheet.Cells(m, 7).Value _
= Left(ActiveSheet.Cells(m, 7).Value, mojisuu - 1) _
& Replace(ActiveSheet.Cells(m, 7).Value, Mid(ActiveSheet.Cells(m, 7).Value, mojisuu, 1), "_", mojisuu, 1)を実行する。
構造は先ほどのReplace関数を用いたコードと同じである。
後は
ActiveSheet.Cells(m, 2).Value = ActiveSheet.Cells(m, 2).Value & vbLf & ActiveSheet.Cells(m, 7).Value
ActiveSheet.Cells(m, 7).Value = ""で、先ほど作成した穴埋め問題を日本語訳のセルに改行した上でコピーし、編集用のセルを空白にする。
以上のフローを指定した問題数でループさせれば、一括で問題作成が可能である。
リセット
作成した穴埋め問題を削除するマクロ「リセット」のコードは下記の通りである。
Sub リセット()
Dim i As Long
Dim start As Long
Dim goal As Long
start = ActiveSheet.Cells(3, 6).Value + 1
goal = ActiveSheet.Cells(5, 6).Value + 1
For i = start To goal
If InStr(ActiveSheet.Cells(i, 2), vbLf) <> 0 Then
ActiveSheet.Cells(i, 2) = Left(ActiveSheet.Cells(i, 2), InStr(ActiveSheet.Cells(i, 2), vbLf) - 1)
End If
Next
End Sub
まずは「問題作成」と同様に
start = ActiveSheet.Cells(3, 6).Value + 1
goal = ActiveSheet.Cells(5, 6).Value + 1
For i = start To goalで、削除する問題番号をセルの行番号に変換し、指定した問題数だけFor文でループする処理の開始を宣言する。
穴埋め問題がある場合はセル内の改行があるため、
If InStr(ActiveSheet.Cells(i, 2), vbLf) <> 0 Thenで改行コードがあるセルに対してのみ削除フローを実行するようにする。
実際の削除コードは下記の通りである。
ActiveSheet.Cells(i, 2) = Left(ActiveSheet.Cells(i, 2), InStr(ActiveSheet.Cells(i, 2), vbLf) - 1)改行コードより前の文字列を残せば、穴埋め問題は削除されて日本語訳のみが残る。
以上のフローを指定した問題数でループさせれば、リセット完了である。
終わりに
今年に入って色々なことに手を出し始めた。
と言っても主に読書と勉強なんだけど、何だかんだ面白いし楽しい。
もう思い切って本棚を追加して本を増やしていこうかななんて考えてる。
まぁそのためにはスペースを確保しなきゃならんのだが、どうしたものか…
END
コメント