語順整序英作文問題を作成するマクロ
おれならこう書く(余計なお世話)
Twitterを眺めていたら、
こういうものを発見。
面白そうなので、〈おれならこう書く〉ってのをやってみようかな、と。
元記事の筆者さんにとっては、完全に
余計なお世話
だと思いますが、見逃してください。
元々のコード
元記事から引用する。
「英文並べ替え問題を自動で作成するExcel VBAプログラム」Dim nowRow As Integer 'プロシージャをまたいで使うのでまず宣言 Sub 総合() MaxRow = ThisWorkbook.Worksheets(1).Range("B1").End(xlDown).Row '「原文」列が何行あるか数える For nowRow = 2 To MaxRow 'その行数分、並び替えを続ける Call この1列 Next Range("A1").Select 'なんとなくカーソルをA1に戻す End Sub Sub この1列() Target = Cells(nowRow, 2).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, 7) = splTarget(n - 2) 'G列に1語ずつ入れる Cells(n, 8) = Rnd 'H列に並べ替え用の乱数を入れる Next Range(Cells(2, 7), Cells(ChaN + 1, 8)) _ .Sort Key1:=Range("H2"), order1:=xlAscending 'G:HをH列で並べ替え narabekae = "( " 'D列に入れる文字列を作成開始(narabekae) For n = 2 To ChaN + 1 narabekae = narabekae & Cells(n, 7).Value & " / " 'G列上から入れ、" / "で区切る Next narabekae = narabekae & ")" & LastT '最後は括弧で閉じて"."か"?"を末尾に足す narabekae = Replace(narabekae, " / )", " )") '最後の一語の処理 narabekae = Replace(narabekae, "+", " ") '一緒になっていた語をバラバラに Cells(nowRow, 4).Value = narabekae '完成したものをD列に入れる Range("G2:H100").Clear '計算用の列は削除 'C列に正解の文章を入れる Seikai = Cells(nowRow, 2).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
こんな感じ。
次のように
同じようなワークシートを作って、やってみよう。
作成したコード
……意外とヒマかかった……。
めんどくさいので、ひとまず作成したコードだけ上げとこう。
プロジェクトの構成
シートモジュール Sh01Main
〈シートの機能〉的側面が強いので、シートモジュールに書いた。「Sh01Main
」というのは自分でつけたオブジェクト名です。
標準モジュール EngUtil
英文を加工する処理は、今後も使うことがあるかも知れないので、標準モジュールに書いた。当然「EngUtil
」というのも自分でつけたオブジェクト名です。
では、実際のコードをどうぞ。
リスト1 シートモジュールSh01Main
Option Explicit 'Constants' Private Enum Sh01ShiftSize sh01ssNumber sh01ssMaterial sh01ssFinished sh01ssSeparated End Enum 'Properties' 'シートの表の部分を返す' Friend Property Get MainTable() As Range Dim rng As Range Set rng = Nothing Set rng = Me.Range("A1").CurrentRegion If rng.Rows.Count < 2 Then GoTo Finalizer With rng Set rng = .Offset(1, 0) Set rng = rng.Resize(.Rows.Count - 1, .Columns.Count) End With Finalizer: Set MainTable = rng End Property 'Methods' Private Sub createQuestions() Dim rng As Range Set rng = Me.MainTable If rng Is Nothing Then Exit Sub Dim i As Long Dim targetCell As Range With rng For i = 1 To .Rows.Count Set targetCell = .Cells(i, 1) '完成品、並べ替え問題を出力するセルの内容をクリア' Call clearContentsBeforeRun(targetCell) '並べ替え素材のあるセルを取得' Dim materialCell As Range Set materialCell = targetCell.Offset(0, sh01ssMaterial) '完成品を出力するセルを取得' Dim finishedCell As Range Set finishedCell = targetCell.Offset(0, sh01ssFinished) '英文の完成品を出力' finishedCell.Value = getArrangedSentence(materialCell.Value) '並べ替え問題を出力するセルを取得' Dim separatedCell As Range Set separatedCell = targetCell.Offset(0, sh01ssSeparated) separatedCell.Value = getRandomizedSentence(materialCell.Value) Next End With End Sub '完成品、並べ替え問題を出力するセルの内容をクリアする' Private Sub clearContentsBeforeRun( _ ByVal targetCell As Range) Dim i As Long With targetCell For i = sh01ssFinished To sh01ssSeparated .Offset(0, i).Value = "" Next End With End Sub 'B列の素材を元に完成品を作成する' Private Function getArrangedSentence( _ ByVal material As String) As String Dim ret As String '「+」記号を半角スペースに置き換える' ret = Replace(material, "+", " ") Dim ar() As String ar = Split(ret) '先頭の単語だけ先頭大文字に' ar(0) = StrConv(ar(0), vbProperCase) 'つなぎ直す' ret = Join(ar) getArrangedSentence = ret End Function '並べ替え問題を作る' Private Function getRandomizedSentence( _ ByVal material) As String Dim ret As String Dim ar() As String ar = EngUtil.getRandomizedWords(material) ret = "( " Dim i As Long For i = LBound(ar) To UBound(ar) - 1 '「+」記号は半角スペースにする' ar(i) = Replace(ar(i), "+", " ") '最後は区切りのスラッシュは要らない' If i = UBound(ar) - 1 Then ret = ret & ar(i) Else ret = ret & ar(i) & " / " End If Next '文末記号を追加' ret = ret & ") " & ar(UBound(ar)) getRandomizedSentence = ret End Function
タテ長になってすまない。
コメントを入れまくっているから、説明は省略。
かなり細かくプロシージャを分割した。
リスト2 標準モジュールEngUtil
Option Explicit Private Enum ErrorCode ecUnknown ecNotSingle = 1 End Enum '英文の加工に関するメソッドを集めたモジュール' '単語をランダムに並べ替えた配列を返す' Public Function getRandomizedWords( _ ByVal targetSentence As String) As String() Const ERR_SOURCE As String = "EngUtil.getRandomizedWords Method" Dim ret() As String Dim wordTerminator As String wordTerminator = Right(targetSentence, 1) '右端の文字が文末記号でなかったら、文末記号を加える' If Not isTerminator(wordTerminator) Then _ wordTerminator = ".": _ targetSentence = targetSentence & wordTerminator 'とりあえずピリオド' 'いったん文末記号を除いた文字列を取得' Dim tmpString As String tmpString = Left(targetSentence, Len(targetSentence) - 1) 'いったん配列化' Dim ar() As String ar = Split(tmpString) '要素数を取得' Dim wordsCount As Long wordsCount = UBound(ar) + 1 '返す配列の要素数を取得(配列は0始まりなのでピリオド等を除いた' '単語数=ピリオドを含めた配列の添字最大値になる)' ReDim ret(wordsCount) 'ランダム並べ替え用の配列を準備' Dim randOrder() As Long randOrder = getRandomOrder(wordsCount) '単語を並べ替えて配列にセット' Dim i As Long For i = LBound(ar) To UBound(ar) ret(i) = ar(randOrder(i) - 1) Next 'この時点で、配列retの最終要素以外に全単語が収まっている' 'retの最終要素に文末記号を入れる' ret(wordsCount) = wordTerminator '配列をreturn' getRandomizedWords = ret End Function Private Function isTerminator( _ ByVal targetChar As String) As Boolean Const ERR_SOURCE As String = "EngUtil.isTerminator Method" Const WORD_TERMINATORS As String = ". ! ?" If Len(targetChar) <> 1 Then Call raiseError(ecNotSingle, _ ERR_SOURCE) isTerminator = True Dim ar() As String ar = Split(WORD_TERMINATORS) Dim i As Long For i = LBound(ar) To UBound(ar) If targetChar = ar(i) Then Exit Function Next isTerminator = False End Function Private Function getRandomOrder( _ ByVal maxNumber As Long, _ Optional ByVal allowDuplicate As Boolean = False) As Long() '///1~maxNumまでの整数をランダムに並べて配列に格納する。' '///引数maxNum:最大数' '///引数allowDuplicate:重複を許可するならTrue' Dim ret() As Long Dim hasSet() As Boolean ReDim hasSet(maxNumber - 1) Dim i As Long ReDim ret(maxNumber - 1) Randomize Dim tmp As Long For i = 0 To maxNumber - 1 Do tmp = Int(maxNumber * Rnd + 1) '///乱数:Int((最大値 - 最小値 + 1) * Rnd + 最小値)' Loop Until hasSet(tmp - 1) = False ret(i) = tmp If Not allowDuplicate Then hasSet(tmp - 1) = True Next getRandomOrder = ret End Function Private Sub raiseError(ByVal errType As ErrorCode, _ ByVal errSource As String) Dim errMsg As String Select Case errType Case ecUnnown: errMsg = "Some error has occurred!" Case ecNotSingle: errMsg = "Arg is not a single-character!" Case Else: errMsg = "Some error has occurred!": errType = ecUnknown End Select Call Err.Raise(Number:=10000 + errType, _ Source:=errSource, _ Description:=errMsg) End Sub
当面必要なさそうなエラー対応まで入れているのでタテ長になってしまっているが、getRandomizedWords
のところだけ見てもらえれば。
シートモジュールに書いたcreateQuestions
メソッドから呼び出している。
実行
シート状にコマンドボタンを置き、createQuestions
メソッドを登録して実行してみる。
バッチリ。
おわりに
本当は、元のコードと比較対照しながらまとめたかったんですけど、めんどくさくてこんな形になってしまいました。