漢字テストメーカーを作ってみた

漢字テストメーカーを作ってみた

プロシージャの構成

ざっとこんな感じ。

ソースコード

リスト1
Private Sub extractQuestions()
'問題データを抽出する'
  Dim dtExtractor As DataExtractor    '……(1)'
  Set dtExtractor = New DataExtractor
  With ThisWorkbook
    Set orgSh = .Worksheets("問題データ")
    Set extractSh = .Worksheets("抽出")
  End With
  dtExtractor.extractData orgSh.Range("A1").CurrentRegion, _
                          Range("CriteriaRange"), _
                          Range("RangeCopyTo")               '……(2)'
  Set dtExtractor = Nothing
End Sub

(1)のDataExtractorクラスについては、

akashi-keirin.hatenablog.com

を参照。

(2)では、そのDataExtractorクラスのextractDataメソッドを使って試験範囲の分の問題だけを「抽出」シートに抽出している。

元データの範囲、条件指定セルの範囲、抽出先ラベル、の3つのRangeオブジェクトを指定するだけで抽出ができるので、これは案外便利かも知れんw

スト2
Private Sub setRandomNumber()
  '乱数を発生させて抽出後の問題番号セルにセットする'
  With ThisWorkbook
    Set extractSh = .Worksheets("抽出")
  End With
  Dim cnt As Integer
  cnt = extractSh.Cells(Rows.Count, 1).End(xlUp).Row - 1
  Dim qNumbers() As Integer
  ReDim qNumbers(1 To cnt)
  Dim i As Integer
  Dim n As Integer
  Dim hasDone As Boolean
  Randomize
  For i = 1 To cnt
    Do
      qNumbers(i) = Int(Rnd * cnt) + 1
      hasDone = True
      If i > 1 Then
        For n = 1 To i - 1
          If qNumbers(i) = qNumbers(n) Then
            hasDone = False
            Exit For
          End If
        Next
      End If
    Loop While hasDone = False
  Next
  '乱数をセルに書き込む'
  For i = 1 To cnt
    extractSh.Range("B" & i + 1).Value = qNumbers(i)
  Next
  '乱数ナンバリングによって並べ替える'
  Call sortExtractedQuestions
End Sub

こちらのプロシージャについては、

akashi-keirin.hatenablog.com

を参照。

リスト3
Private Sub sortExtractedQuestions()
'抽出シートを並べ替える'
  Set extractSh = ThisWorkbook.Worksheets("抽出")
  With extractSh
    .Range("A1").CurrentRegion.Sort _
      Key1:=.Range("B2"), _
      Header:=xlYes, _
      Order1:=xlAscending
  End With
End Sub

こちらも、単におなじみ、RangeオブジェクトのSortメソッドを使っているだけなので、説明不要と思う。

リスト4
Private Sub setQuestions()
  'テスト問題の様式に問題データをセットする'
  With ThisWorkbook
    Set orgSh = .Worksheets("問題データ")
    Set extractSh = .Worksheets("抽出")
  End With
  Dim i As Integer
  Dim objCell As Range
  For i = 1 To Range("NumberOfQuestions").Value
    Set objCell = extractSh.Range("C" & i + 1)
    '下線部のフォントを変える'
    Call changeFontIfUnderLine(objCell, "MS Pゴシック")
    '問題データを問題様式に貼り付ける'
    objCell.Copy
    With Range("Question" & Format(i, "0#"))    '……(1)'
      .PasteSpecial xlPasteValues    '……(2)'
      .PasteSpecial xlPasteFormats    '……(3)'
      .Orientation = xlVertical    '……(4)'
      .VerticalAlignment = xlTop    '……(5)'
      .HorizontalAlignment = xlCenter    '……(6)'
      .WrapText = True    '……(7)'
    End With
  Next
  Range("NumberOfTimes").Value = Range("CriteriaRange").Cells(2, 1).Value    '……(8)'
  Range("TestBody").Copy Range("CopyStartCell")    '……(9)'
  Application.CutCopyMode = False
End Sub

並べ替え終わった問題データをテスト問題の様式に貼り付けていくだけなんだが、横書きのデータを縦書きにして、なおかつ文字の書式はそのまま、ということなので、それなりにメンドウだった。

(1)からの8行

With Range("Question" & Format(i, "0#"))    '……(1)'
  .PasteSpecial xlPasteValues    '……(2)'
  .PasteSpecial xlPasteFormats    '……(3)'
  .Orientation = xlVertical    '……(4)'
  .VerticalAlignment = xlTop    '……(5)'
  .HorizontalAlignment = xlCenter    '……(6)'
  .WrapText = True    '……(7)'
End With

クリップボードにコピーされた問題データを貼り付けるだけなのだが、こんなにメンドウなことになっている。

縦書きにすると、右から左、という不自然な順序で貼り付けないといけないので、あらかじめ問題転記先のセルに右から左に「Question01」~「Question05」という風に名前を定義している。

こうしておくことで、(1)の

Range("Question" & Format(i, "0#"))

のようにForループと相性の良い形で問題の転記先を指定することができる。

(2)~(7)は貼り付け方の指定。

一応、列挙しておくと、

  • (2):値のみ貼り付け
  • (3):書式貼り付け
    下線とかフォントの情報を貼り付けるためには致し方ない?
  • (4):縦書きにする
  • (5):縦位置は上揃え
  • (6):横位置中央揃え
  • (7):テキストの折り返し

フォント情報や下線情報を保持したまま貼り付けるために書式ごと貼り付けると、問題様式側の書式が死ぬので、貼り付けた直後に設定し直す、といった流れになっている。もっとうまいやり方がありそうだけど。

リスト5
Private Sub changeFontIfUnderLine(ByVal objCell As Range, _
                                  ByVal fontName As String)
'下線が施された文字のフォントを変える'
  Dim i As Integer
  Dim hasStarted As Boolean
  Dim tmpStart As Integer
  Dim tmpEnd As Integer
  For i = 1 To Len(objCell.Value)
    With objCell.Characters(i, 1)
      '初めてアンダーラインにぶつかったときのiを記録する'
      If hasStarted = False And _
         .Font.Underline <> xlUnderlineStyleNone Then
        tmpStart = i
        hasStarted = True
      End If
      'hasStartedがTrueの状態でアンダーラインのない文字にぶつかったら'
      '下線部が終わったということなのでiを記録してループを抜ける。'
      If hasStarted = True And _
         .Font.Underline = xlUnderlineStyleNone Then
        tmpEnd = i
        Exit For
      End If
    End With
  Next
  DoEvents
  'この時点でtmpEnd - tmpStartの値がアンダーライン文字列の字数'
  'アンダーラインの部分のフォントを変える'
  objCell.Characters(tmpStart, tmpEnd - tmpStart).Font.Name = fontName
  hasStarted = False
End Sub

こちらについては、

akashi-keirin.hatenablog.com

をどうぞ。

実行結果

「問題データ」シートに、

f:id:akashi_keirin:20170514152627j:plain

こんなふうに問題データを準備。

「抽出」シートは、

f:id:akashi_keirin:20170514152634j:plain

こんな具合に抽出用の項目ラベルと条件指定用セルを準備。

んで、下記のコードで実行した。

Option Explicit

Dim orgSh As Worksheet
Dim extractSh As Worksheet

Public Sub main()
  Call extractQuestions
  Call setRandomNumber
  Call setQuestions
End Sub

f:id:akashi_keirin:20170514152645j:plain

おお、うまいことできとる!

Excelの画面上ではガタガタだけれど、PDFにしてみると、

f:id:akashi_keirin:20170514152652j:plain

まあまあいい感じではないでしょうか。

おわりに

もっとサクッとできると思っていたけど、縦書きにしないといけないこともあって、案外手間取ってしまった。

しかし、けっこう使い慣れてきたと思っていたExcelVBAにも未知のオブジェクトがたくさんあってちょっとびびってしまった。達人への道のりは長いなあ……。

@akashi_keirin on Twitter