漢字テストメーカーを作ってみた
漢字テストメーカーを作ってみた
プロシージャの構成
- 問題データ抽出用プロシージャ
Private Sub extractQuestions - 乱数発生・ナンバリング用プロシージャ
Private Sub setRandomNumber - 抽出問題並べ替えプロシージャ
Private Sub sortExtractedQuestions - テスト様式への転記プロシージャ
Private Sub setQuestions - 下線部フォント変更プロシージャ
Private Sub changeFontIfUnderLine
ざっとこんな感じ。
ソースコード
リスト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クラスについては、
を参照。
(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
こちらのプロシージャについては、
を参照。
リスト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
こちらについては、
をどうぞ。
実行結果
「問題データ」シートに、
こんなふうに問題データを準備。
「抽出」シートは、
こんな具合に抽出用の項目ラベルと条件指定用セルを準備。
んで、下記のコードで実行した。
Option Explicit Dim orgSh As Worksheet Dim extractSh As Worksheet Public Sub main() Call extractQuestions Call setRandomNumber Call setQuestions End Sub
おお、うまいことできとる!
Excelの画面上ではガタガタだけれど、PDFにしてみると、
まあまあいい感じではないでしょうか。
おわりに
もっとサクッとできると思っていたけど、縦書きにしないといけないこともあって、案外手間取ってしまった。
しかし、けっこう使い慣れてきたと思っていたExcelVBAにも未知のオブジェクトがたくさんあってちょっとびびってしまった。達人への道のりは長いなあ……。