【改】英文並べ替え問題を自動で作成するExcel VBAプログラム
昨日のブログに書いた英文並べ替え問題作成プログラム、そこそこ反応があった*1ので、調子に乗って改訂版を作りました。
昨日のは一文丸ごと並べ替えるものでしたが、今回は英文の一部を並べ替えられるという、より実践的なものです。
Dim nowRow As Integer 'プロシージャをまたいで使うのでまず宣言
Dim taipu As Integer
Sub 総合()
MaxRow = ThisWorkbook.Worksheets(1).Range("F1").End(xlDown).Row '「原文」列が何行あるか数える
For nowRow = 2 To MaxRow 'その行数分、並び替えを続ける
Cells(nowRow, 4).Value = " " '原文と解答の間を見やすくわけるため、D列に空白を入れる。なくてもいいかも。
Call 前中後チェック
If taipu = 0 Then
Call 中のみ
ElseIf taipu = 1 Then
Call 前中
ElseIf taipu = 10 Then
Call 中後
ElseIf taipu = 11 Then
Call 前中後
End If
Next
Range("A1").Select 'なんとなくカーソルをA1に戻す
End Sub
Sub 前中後チェック()
'00→前も後ろもなし 01→前のみあり 10→後ろのみあり 11→前も後ろもあり、という場合分け
taipu = 0
If Cells(nowRow, 5) <> "" Then taipu = taipu + 1
If Cells(nowRow, 7) <> "" Then taipu = taipu + 10
End Sub
Sub 中のみ()
Target = Cells(nowRow, 6).Value '並べ替え対象
LastT = Right(Target, 1) '最後の1文字（"."か"?"）をとっておく
Target = Left(Target, Len(Target) - 1) 'ひとまず最後の1文字を消す
ChaN = Len(Target) - Len(Replace(Target, " ", "")) + 1 'スペースの数＋1が単語数（ChaN）
splTarget = Split(Target, " ") '空白で区切って配列に格納
For n = 2 To ChaN + 1 '2行目から[単語数＋1]行目までFor
Cells(n, 9) = splTarget(n - 2) 'I列に1語ずつ入れる
Cells(n, 10) = Rnd 'J列に並べ替え用の乱数を入れる
Next
Range(Cells(2, 9), Cells(ChaN + 1, 10)) _
.Sort Key1:=Range("J2"), order1:=xlAscending 'I:JをJ列で並べ替え
narabekae = "( " 'B列に入れる文字列を作成開始（narabekae）
For n = 2 To ChaN + 1
narabekae = narabekae & Cells(n, 9).Value & " / " 'I列上から入れ、" / "で区切る
Next
narabekae = narabekae & ")" & LastT '最後は括弧で閉じて"."か"?"を末尾に足す
narabekae = Replace(narabekae, " / )", " )") '最後の一語の処理
narabekae = Replace(narabekae, "+", " ") '一緒になっていた語をバラバラに
Cells(nowRow, 2).Value = narabekae '完成したものをB列に入れる
Range("I2:J100").Clear '計算用の列は削除
'C列に正解の文章を入れる
Seikai = Cells(nowRow, 6).Value 'もう一度原文を取得
Seikai = Replace(Seikai, "+", " ") '"+"を" "に置換
First = StrConv(Left(Seikai, 1), vbUpperCase) '最初の一文字を切り出し、大文字に
Seikai = First & Mid(Seikai, 2, 100) '大文字にした1文字目と、そのままの2文字目以下を合体
Cells(nowRow, 3).Value = Seikai '完成したものをC列に入れる
End Sub
Sub 前中()
Front = Cells(nowRow, 5).Value '並べ替え対象の前の部分
'文頭は大文字になっているはずなので、最初の1字を大文字にする
First = StrConv(Left(Front, 1), vbUpperCase) '最初の一文字を切り出し、大文字に
Front = First & Mid(Front, 2, 100) '大文字にした1文字目と、そのままの2文字目以下を合体
Target = Cells(nowRow, 6).Value '並べ替え対象
If Left(Target, 1) = " " Then Target = Right(Target, Len(Target) - 1) '最初の1字がスペースなら消す
LastT = Right(Target, 1) '最後の1文字（"."か"?"）をとっておく
Target = Left(Target, Len(Target) - 1) 'ひとまず最後の1文字を消す
ChaN = Len(Target) - Len(Replace(Target, " ", "")) + 1 'スペースの数＋1が単語数（ChaN）
splTarget = Split(Target, " ") '空白で区切って配列に格納
For n = 2 To ChaN + 1 '2行目から[単語数＋1]行目までFor
Cells(n, 9) = splTarget(n - 2) 'I列に1語ずつ入れる
Cells(n, 10) = Rnd 'J列に並べ替え用の乱数を入れる
Next
Range(Cells(2, 9), Cells(ChaN + 1, 10)) _
.Sort Key1:=Range("J2"), order1:=xlAscending 'I:JをJ列で並べ替え
narabekae = Front & " ( " 'B列に入れる文字列を作成開始（narabekae）並べ替え前の後に半角スペースを入れてつなげる
For n = 2 To ChaN + 1
narabekae = narabekae & Cells(n, 9).Value & " / " 'I列上から入れ、" / "で区切る
Next
narabekae = narabekae & ")" & LastT '最後は括弧で閉じて"."か"?"を末尾に足す
narabekae = Replace(narabekae, " / )", " )") '最後の一語の処理
narabekae = Replace(narabekae, "+", " ") '一緒になっていた語をバラバラに
narabekae = Replace(narabekae, " ", " ") '何かの間違いで半角スペースが2字連続していたら修正
Cells(nowRow, 2).Value = narabekae '完成したものをB列に入れる
Range("I2:J100").Clear '計算用の列は削除
'C列に正解の文章を入れる
Seikai = Front & " " & Cells(nowRow, 6).Value 'もう一度原文を取得
Seikai = Replace(Seikai, "+", " ") '"+"を" "に置換
Seikai = Replace(Seikai, " ", " ") '念のため2字連続の半角スペースがあったら1字に。
Cells(nowRow, 3).Value = Seikai '完成したものをC列に入れる|
End Sub
Sub 中後()
Back = Cells(nowRow, 7).Value '並べ替え対象の後ろの部分
Target = Cells(nowRow, 6).Value '並べ替え対象
'もしTargetの末尾に半角スペースが入っていると語数のカウントが狂うので、末尾の半角スペースは削除
Last = Right(Target, 1)
If Last = " " Then Target = Left(Target, Len(Target) - 1)
ChaN = Len(Target) - Len(Replace(Target, " ", "")) + 1 'スペースの数＋1が単語数（ChaN）
splTarget = Split(Target, " ") '空白で区切って配列に格納
For n = 2 To ChaN + 1 '2行目から[単語数＋1]行目までFor
Cells(n, 9) = splTarget(n - 2) 'I列に1語ずつ入れる
Cells(n, 10) = Rnd 'J列に並べ替え用の乱数を入れる
Next
Range(Cells(2, 9), Cells(ChaN + 1, 10)) _
.Sort Key1:=Range("J2"), order1:=xlAscending 'I:JをJ列で並べ替え
narabekae = "( " 'C列に入れる文字列を作成開始（narabekae）
For n = 2 To ChaN + 1
narabekae = narabekae & Cells(n, 9).Value & " / " 'I列上から入れ、" / "で区切る
Next
narabekae = narabekae & ")" & LastT '最後は括弧で閉じて"."か"?"を末尾に足す
narabekae = Replace(narabekae, " / )", " )") '最後の一語の処理
narabekae = Replace(narabekae, "+", " ") '一緒になっていた語をバラバラに
narabekae = narabekae & " " & Back '完成したものをB列に入れる
narabekae = Replace(narabekae, " ", " ") '念のため2字連続スペースを修正
Cells(nowRow, 2).Value = narabekae
Range("I2:J100").Clear '計算用の列は削除
'C列に正解の文章を入れる
Seikai = Cells(nowRow, 6).Value & " " & Back 'もう一度原文を取得
Seikai = Replace(Seikai, "+", " ") '"+"を" "に置換
Seikai = Replace(Seikai, " ", " ") '2字連続スペース避け
First = StrConv(Left(Seikai, 1), vbUpperCase) '最初の一文字を切り出し、大文字に
Seikai = First & Mid(Seikai, 2, 100) '大文字にした1文字目と、そのままの2文字目以下を合体
Cells(nowRow, 3).Value = Seikai '完成したものをC列に入れる
End Sub
Sub 前中後()
Front = Cells(nowRow, 5).Value '並べ替え対象の前の部分
'文頭は大文字になっているはずなので、最初の1字を大文字にする
First = StrConv(Left(Front, 1), vbUpperCase) '最初の一文字を切り出し、大文字に
Front = First & Mid(Front, 2, 100) '大文字にした1文字目と、そのままの2文字目以下を合体
Back = Cells(nowRow, 7).Value '並べ替え対象の後ろの部分
Target = Cells(nowRow, 6).Value '並べ替え対象
'もしTargetの最初／最後に半角スペースが入っていると語数のカウントが狂うので、削除
If Left(Target, 1) = " " Then Target = Right(Target, Len(Target) - 1) '最初の1字がスペースなら消す
If Right(Target, 1) = " " Then Target = Left(Target, Len(Target) - 1) '最後の1字がスペースなら消す
ChaN = Len(Target) - Len(Replace(Target, " ", "")) + 1 'スペースの数＋1が単語数（ChaN）
splTarget = Split(Target, " ") '空白で区切って配列に格納
For n = 2 To ChaN + 1 '2行目から[単語数＋1]行目までFor
Cells(n, 9) = splTarget(n - 2) 'G列に1語ずつ入れる
Cells(n, 10) = Rnd 'J列に並べ替え用の乱数を入れる
Next
Range(Cells(2, 9), Cells(ChaN + 1, 10)) _
.Sort Key1:=Range("J2"), order1:=xlAscending 'I:JをJ列で並べ替え
narabekae = Front & " ( " 'B列に入れる文字列を作成開始（narabekae）
For n = 2 To ChaN + 1
narabekae = narabekae & Cells(n, 9).Value & " / " 'G列上から入れ、" / "で区切る
Next
narabekae = narabekae & ") " & Back
narabekae = Replace(narabekae, " / )", " )") '括弧内最後の一語の処理
narabekae = Replace(narabekae, "+", " ") '一緒になっていた語をバラバラに
narabekae = Replace(narabekae, " ", " ") '2字連続スペース避け
Range("I2:J100").Clear '計算用の列は削除
Cells(nowRow, 2).Value = narabekae '問題文をB列に入れる
Seikai = Front & " " & Cells(nowRow, 6).Value & " " & Back
Seikai = Replace(Seikai, "+", " ")
Seikai = Replace(Seikai, " ", " ")
Cells(nowRow, 3) = Seikai
End Sub見る人が見ればすぐお分かりの通り、とても汚いです。なんか同じのいっぱい出てきてるし。
時間があれば似たところをまとめてプロシージャ化してスッキリ、と行きたいところでしたが、まあ実用性はそう変わらないはず。笑
あとおそらくコメントアウトしている部分にミス（昨日のからコピペしているので列番号とか）があるかと思いますが、ご容赦下さい。
| A | B | C | D | E | F | G |
|---|---|---|---|---|---|---|
| No. | 問題文 | 解答 | 原文_前 | 原文_並べ替え部分 | 原文_後 | |
| 1 | how dare you say such+a+thing? | |||||
| 2 | Kagawa | has+decided to transfer to one of the+most+popular football+teams. | ||||
| 3 | this+book made me think | that UFOs exist. | ||||
| 4 | Jennifer | must not have said such+a+thing | to you. |
これに対して上のプログラム「総合」を実行すると、
| A | B | C | D | E | F | G |
|---|---|---|---|---|---|---|
| No. | 問題文 | 解答 | 原文_前 | 原文_並べ替え部分 | 原文_後 | |
| 1 | ( you / say / dare / how / such a thing )? | How dare you say such a thing? | how dare you say such+a+thing? | |||
| 2 | Kagawa ( the most popular / of / to / has decided / to / football teams / one / transfer ). | Kagawa has decided to transfer to one of the most popular football teams. | Kagawa | has+decided to transfer to one of the+most+popular football+teams. | ||
| 3 | ( this book / think / made / me ) that UFOs exist. | This book made me think that UFOs exist. | this+book made me think | that UFOs exist. | ||
| 4 | Jennifer ( not / must / have / said / such a thing ) to you. | Jennifer must not have said such a thing to you. | Jennifer | must not have said such+a+thing | to you. |
並べ替え問題に関してはこれで十分なんじゃないかと思うのでこれくらいにして、またいずれ作れそうなのがあったら挑戦してみようと思いました。
もし今回の使ってみてなんか変なことになってしまった方がいましたら、すみません(in advance)。
今日は昼に三脚を返すためだけに大学に行ったんだけど、友だちとご飯食べられたし、それ以外にも友だちに4人くらい遭遇出来て、とてもいい日だった。体調も戻ってきたし。
問題は修論に、明日の最終面接だ…!!
*1:いつもはまったくないので、少しでも反応があったら「そこそこ」です。笑
