語順整序英作文問題を作成するマクロ

おれならこう書く（余計なお世話）

Twitterを眺めていたら、

thunder0512.hatenablog.com

こういうものを発見。

面白そうなので、〈おれならこう書く〉ってのをやってみようかな、と。

元記事の筆者さんにとっては、完全に

余計なお世話

だと思いますが、見逃してください。

元々のコード

元記事から引用する。

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

「英文並べ替え問題を自動で作成するExcel VBAプログラム」

こんな感じ。

次のように

同じようなワークシートを作って、やってみよう。

作成したコード

……意外とヒマかかった……。

めんどくさいので、ひとまず作成したコードだけ上げとこう。

プロジェクトの構成

シートモジュール　Sh01Main

〈シートの機能〉的側面が強いので、シートモジュールに書いた。「Sh01Main」というのは自分でつけたオブジェクト名です。

標準モジュール　EngUtil

英文を加工する処理は、今後も使うことがあるかも知れないので、標準モジュールに書いた。当然「EngUtil」というのも自分でつけたオブジェクト名です。

では、実際のコードをどうぞ。

リスト１　シートモジュール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

タテ長になってすまない。

コメントを入れまくっているから、説明は省略。

かなり細かくプロシージャを分割した。

リスト２　標準モジュール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メソッドを登録して実行してみる。

バッチリ。

おわりに

本当は、元のコードと比較対照しながらまとめたかったんですけど、めんどくさくてこんな形になってしまいました。