漢字テストメーカーを作ってみた
漢字テストメーカーを作ってみた
プロシージャの構成
- 問題データ抽出用プロシージャ
Private Sub extractQuestions - 乱数発生・ナンバリング用プロシージャ
Private Sub setRandomNumber - 抽出問題並べ替えプロシージャ
Private Sub sortExtractedQuestions - テスト様式への転記プロシージャ
Private Sub setQuestions - 下線部フォント変更プロシージャ
Private Sub changeFontIfUnderLine
ざっとこんな感じ。
ソースコード
リスト１
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メソッドを使って試験範囲の分の問題だけを「抽出」シートに抽出している。
元データの範囲、条件指定セルの範囲、抽出先ラベル、の３つのRangeオブジェクトを指定するだけで抽出ができるので、これは案外便利かも知れんｗ
リスト２
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
こちらのプロシージャについては、
を参照。
リスト３
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メソッドを使っているだけなので、説明不要と思う。
リスト４
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, "ＭＳ Ｐゴシック")
'問題データを問題様式に貼り付ける'
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)からの８行
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)：テキストの折り返し
フォント情報や下線情報を保持したまま貼り付けるために書式ごと貼り付けると、問題様式側の書式が死ぬので、貼り付けた直後に設定し直す、といった流れになっている。もっとうまいやり方がありそうだけど。
リスト５
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にも未知のオブジェクトがたくさんあってちょっとびびってしまった。達人への道のりは長いなあ……。
セル内のアンダーライン部分のみフォントを変える
文字列のうち、アンダーライン部分のフォントだけを変える
ツイッターのフォロワーさんの「漢字テストの問題をランダムに作成できんかなー」みたいなツイートに反応して、どうやったらできるのか考えてみた。
傍線部分だけゴシックにしないといけない
文字列に下線（傍線）を引くのは自動化できないにしても、下線部だけを狙い撃ちでフォントを変えるというのは、手作業でやると死ぬほどめんどくさい。
しかし、普段文字単位で書式をいじくることなんて皆無だから、どうしていいのか分からなかった。んで、調べてみると、Charactersオブジェクトを取得して書式を施せばよいと分かった。
Characters オブジェクトを使用すると、文字列のうちの一部だけを対象にした修正ができます。
Characters オブジェクトを取得するには、Characters(start, length) プロパティを使用します。引数 start には開始する文字の先頭位置の番号を指定します。引数 length には、文字数を指定します。
ということなので、なんとかなりそう。
考え方
次のような考え方でコードを書くことにした。
- １文字目から順番にチェックする
- 初めてアンダーラインのある文字にぶつかったときにフラグを立て、何文字目かを変数tmpStartに記録する
- アンダーラインのない文字にぶつかったら、何文字目かを変数tmpEndに記録してループを抜ける
- Charactersオブジェクトの引数startにtmpStartを、引数lengthにtmpEnd - tmpStartを渡すと、アンダーライン部分のCharactersオブジェクトが取得できる
- 後は、4.で得られたCharactersオブジェクトのFontプロパティをあれこれいじくる
と、こんな感じ。
実装
リスト１
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
'この時点でtmpEnd - tmpStartの値がアンダーライン文字列の字数'
'アンダーラインの部分のフォントを変える'
objCell.Characters(tmpStart, tmpEnd - tmpStart).Font.Name = fontName
End Sub
コード中のコメントでだいたい何をやっているのかは分かると思う。
全体の処理の途中で呼び出すメソッドのようなものなので、Privateにして呼び出され専用にしてある。引数で渡している処理対象セルやフォント名を決め打ちにしてやれば、単独のプロシージャとしても使えると思う。
実行結果
明朝体の「ケイオウカク」のところだけが、
無事にゴシック体になった。
おわりに
Charactersオブジェクトをうまく使えば、Excelのセル内の文字列に関するしちめんどくさい作業のかなりの部分を軽減できるようになるかも知れない。
いづれは、クラスを作って手軽に扱えるようにしてみたい。
重複のない乱数発生のアルゴリズムを考えてみた
重複のない乱数を作る
重複のない乱数を発生させるアルゴリズムを考えてみた。まあ、ちょこっとggったらスマートなやつが見つかるとは思ったけど、自分で考えるというのが大事だと思ったのですよ。
素人丸出しのやり方なので、笑ってくれたらいいと思います。
考え方
ちょこっと作戦を考えてみた。
たとえば、１～10までの乱数を作るだけなら、Rnd関数を用いて、
Int(Rnd * 10) + 1
とでもすればよかろう。
問題は、これだけだと同じ数が出てきてしまうことだ。
順番をランダムに変えたいようなとき、これでは困る。
そこで、次のような手順を考えた。
- 10個の値を格納することができる配列を準備する
- 乱数を発生させる
- （２回目以降）発生させた値を、それまでに格納した全ての値と比べる
- 同じ値にぶつかったら、乱数発生をやり直して3.に戻る
- 一度も同じ値にぶつからずに3．を終えると、新たに配列に追加する
- 2.に戻る
このやり方でできると思った。
実装
リスト１
Dim qNumbers() As Integer '……(1)'
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 '……(2)'
hasDone = True '……(3)'
If i > 1 Then '……(4)'
For n = 1 To i - 1 '……(5)'
If qNumbers(i) = qNumbers(n) Then
hasDone = False
Exit For
End If
Next
End If
Loop While hasDone = False '……(6)'
Next
まず、(1)からの２行、
Dim qNumbers() As Integer ReDim qNumbers(1 To cnt)
では、作成した乱数を格納する配列を用意し、要素数でReDimしている。cntというのは、要素数が入っている変数だと思ってください。
(2)の
qNumbers(i) = Int(Rnd * cnt) + 1
で、１～10までの数を１つ作り、ひとまず配列qNumbersに格納。
一旦(3)で
hasDone = True
としてフラグ用の変数をTrueにしておく。
すでに取得済みの数と比較する必要があるのは、ループの２回目以降なので、(4)の
If i > 1 Then
で、ループの１回目のみ(5)以下のForループを飛ばすようにした。
(5)以下の６行、
For n = 1 To i - 1 '……(5)'
If qNumbers(i) = qNumbers(n) Then
hasDone = False
Exit For
End If
Next
が重複を防ぐためのロジック。
Forループの最終値を「i - 1」にしておかないと無限ループになるので注意ｗ（←経験者）
１つ手前までのqNumbersの全ての要素と比較し、同じ値があったら即hasDoneをFalseにしてループを抜けるようにした。
従って、このループを無事抜けるということは、重複のない値がセットされていて、hasDoneがTrueになっているということ。
(6)では、Doループの繰り返し条件としてhasDone = Falseを指定しているので、重複のない値が取得できていないときはDoループの先頭に戻って値を取得しなおすことになる。
実行結果
cntを10にして、リスト１に
For i = 1 To cnt debug.Print qNumbers(i) Next
を付け加えて実行してみると、
無事に重複なく1～10の数字が格納されていることが分かる。
おわりに
重複のない乱数の取得なんていうのは、さんざん考え尽くされた類のものだと思うので、もっとエレガントかつスマートなやり方があると思う。
もう少し仕事に余裕があったら、本格的にアルゴリズムの勉強をするんだけどなあ。
マクロなし縛りでドロップダウンリストの項目を切り替える
マクロなし縛りでドロップダウンリスト項目を動的に切り替える
「マクロなし縛り」でExcelでの様式づくりをせざるを得なくなったので、久しぶりに関数であれこれやってみた。
ろくにワークシート関数も覚えていないのにマクロを覚えてしまったために、「欲しい機能は自分で作る」みたいになっていた。達人が見たら「そんなもん、ワークシート関数使ったら一発やろがぼけー」状態だったかも知れん。
せっかくの機会なので、ちょっとまじめにExcelのワークシート関数を使ってみた。
「データの入力規則」リストの切り替え
ユーザに変なデータ入力をさせないために、よくお世話になる「データの入力規則」。
特に、ドロップダウンリストで項目を選択させることのできる「リスト」機能は重宝する。
このリストの項目を条件によって切り替える、ということをやってみた。
準備
ワークシート上に、リスト用の表を２つ作る。
１つ目のリストには「フラワーライン」と名前を定義し、
２つ目のリストには「反フラワー」と名前を定義しておく。
INDIRECT関数
んで、
名前だけは知っていたけど使ったことなかったExcel関数選手権
でもやったら結構いいところまで行くんじゃないか、と個人的には思っているINDIRECT関数ですよ。
基本的には、
=INDIRECT(セル番地)
の形で、セル参照を返してくれるという関数。
たとえば、
こんなふうに、Ｋ５セルに「デコスケ」と入力されているときに、
=INDIRECT("K5")
を計算すると、
こんなふうにＫ５セルの値が返る。
ということは、INDIRECT関数に渡す引数を切り替えてやれば、リスト項目を切り替えることができるということになる。
「データの入力規則」の設定
「元の値」のところを、
=INDIRECT($E$1)
にして、Ｅ１セルに「フラワーライン」と入力すると、
リスト項目はこの通り。
Ｅ１セルに「反フラワー」と入力すると、
リスト項目が変わった。
おわりに
入力された値に応じて動的に何かを切り替える、となると、安易にWorksheetのイベントマクロなんかで済ませようと考えがちだけれど、たまに「マクロなし縛り」という状況に追い込んでみると
名前は知っていたけど使ったことなかったExcel関数
が使えるようになるきっかけになるかも知れない、と思いました。
ワークシート関数もしっかりマスターしないといけないなあ。
文字列の中の必要な部分にだけ書式設定をする
指定した文字の書式だけを変更する
記入見本作り
記入例を作りたかったんだが、日付の欄は、
こんな感じで、「月」と「日」と「（」、「）」をあらかじめ入れておいて、月・日・曜日だけを書いてもらうようにしている。
んで、記入者に書いてもらう部分だけを手書き風のフォントに変えて記入例を作ろうと思った。
しかし、ちょっと考えたら分かると思うが、これはめんどくさい。
たとえば、
７月23日（日）
という記入例を作ろうと思ったら、
「７」と「23」と「日」（曜日の方）だけを選択してフォントを変える
というしちめんどくさいことになる。
まあ、ちまちまと時間をかけて努力するのが好きな人ならそれほど苦痛ではないだろうが、私にとっては端的に苦痛ですｗ
んで、WordVBAの練習も兼ねてやってみた。
必要な部分だけ書式を変更するマクロ
Wordのオブジェクト構造がイマイチよく分かっとらんので、かなり行き当たりばったりのコードだと思うが、恥ずかしげもなく載せる。
リスト１
Option Explicit
Public Const FONT_TO_USE As String = "HG正楷書体-PRO" '……(1)'
Public Sub setFontNameAndItalic()
Dim chr As String '……(2)'
Dim i As Integer
Dim numOfChar As Integer
Dim flg As Boolean
numOfChar = Selection.Range.Characters.Count '……(3)'
For i = 1 To numOfChar
chr = Selection.Range.Characters(i) '……(4)'
If flg = True And chr <> "）" Then '……(5)'
With Selection.Range.Characters(i).Font '……(*)'
.Name = FONT_TO_USE
.Italic = True
End With
End If
If chr = "月" Or chr = "日" Or _
chr = "（" Or chr = "）" Then '……(6)'
If chr = "（" Then flg = True '……(7)'
If chr = "）" Then flg = False '……(8)'
Else
With Selection.Range.Characters(i).Font
.Name = FONT_TO_USE
.Italic = True
End With
End If
Next
End Sub
改めて見直すと、ブサイクなコードです。。。(´・ω・`)ｼｮﾎﾞｰﾝ
まずは、(*)のところ。実はこれがメインの処理だったりする。
With Selection.Range.Characters(i).Font '……(*)' .Name = FONT_TO_USE .Italic = True End With
まず、Withでまとめている
Selection.Range.Characters(i).Font
では、選択箇所のRangeオブジェクトの中にある文字列Charactersコレクションのi番目の文字のFontプロパティを呼び出して、Fontオブジェクトを取得している。
んでもって、次の２行、
.Name = FONT_TO_USE .Italic = True
でフォントの種類と斜体を設定する。
この処理を、それぞれの文字に対して実行するかどうかを切り替える、というやり方をしている。
ちなみに、「FONT_TO_USE」というのは定数で、リスト１の(1)で
Public Const FONT_TO_USE As String = "HG正楷書体-PRO"
と指定している。
(2)からの４行は、変数の宣言。
chr
Charactersコレクションから取得した１文字を入れる。(*)の処理を施すかどうかの条件判定に使用。別になくても良いが、コードを短くするために使っている。
i
おなじみループカウンタ。
numOfChar
選択中の文字数を格納する。Forループの上限値として使用。
flg
(*)の処理を行うかどうかを切り替えるためのフラグ。
(3)の
numOfChar = Selection.Range.Characters.Count
では、CharactersコレクションのCountプロパティを用いて文字数を取得し、変数numOfCharに格納。
ここからがForループの中身。
まず、(4)の
chr = Selection.Range.Characters(i)
で１文字を変数chrに格納。
(5)の
If flg = True And chr <> "）" Then
という条件分岐により、この段階でflgがTrueになっていたら、「）」でない限り(*)の処理を実行してしまう。
(7)のところで、「（」に出会ったらflgをTrueにするようにしているので、「（」に出会った直後のループでは、(*)を実行する。ただし、その直後はflgがTrueのままなので、放っておいたら「）」にまで(*)を実行してしまう。
それを防ぐための条件設定。うーーーむ、ブサイクすぎる。。。
(6)の
If chr = "月" Or chr = "日" Or chr = "（" Or chr = "）" Then
は、一番初歩的な条件設定。
「月」、「日」、「（」、「）」だったら何もしない、ということ。
ただし、めんどくさいのは、(*)の処理を施したい対象の中にも「月」、「日」という文字があること。言うまでもなく曜日を表す方の「月」、「日」だ。
幸い、曜日を表す方の「月」、「日」には、
「（）」で括られている
という特徴があるので、
「（」に出会ったらスイッチオン、「）」に出会ったらスイッチオフ
というやり方にした。
……と書いているうちに、
カッコで括られているのは１文字って決まってるんだから、「（」に出会って次の１字に(*)の処理を施したら即flgをFalseにしたらいいんじゃね？？？
と思いついたというのは内緒だｗ
(7)、(8)の
If chr = "（" Then flg = True If chr = "）" Then flg = False
がスイッチ切り替え。
「（」に出会ったらスイッチオン、「）」に出会ったらスイッチオフ、というイメージ。
実行結果
こんなふうに、日付欄を選択して実行すると、
この通り、意図したとおりの結果となった。
おわりに
ツッコミどころ満載のコードだということは認めます。
正直、Wordのオブジェクト構造がイマイチ理解できていないので、アホみたいなコードになっていると思います。これを機に勉強しようとは思うものの、ホントにやるかどうかは分かりませんｗ
ただ、ちょい書きでこのぐらいできたら、しちめんどくさい作業をせずに済む（しかも、コードを書くのは楽しいので、しょうもないはずの作業が楽しくなる）ので、まあええかな、と。
Wordの表の各セルの文字列を利用しやすくする(3)
WordTableCreatorクラスの修正
id:mmYYmmdd さんからのコメント
前回の記事に、id:mmYYmmdd さんからコメントをいただいた。
全く以て仰せのとおり、というところなので、アドヴァイスに沿ってコードを修正する。
雑な配列の定義を改める
まずは、
ReDim tableArray_(1 To maxRow_, 1 To maxColumn_) とするかクラスモジュールの先頭に Option Base 1 を宣言するかしないと0番目の要素が余分になってしまいます
正直、配列を使い始めたのが割と最近だったもので、扱いが雑でした。「動きゃいい」という感覚でやっていたことは否めません。やはり、きっちりとしないといけませんな。
というわけで、二次元配列の要素数が確定した後、ReDimするところを次のように訂正する。
リスト１
ReDim tableArray_(1 To maxRow_, 1 To maxColumn_)
表のセル番地との対応を優先して1始まりにしたんですが、後々のことを考えたら0始まりの方がいいのかも……。このあたりは経験不足で何とも……。
配列をまるごと取り出すメソッドの導入
こちらについては、
テーブル丸ごと出力する関数を用意すれば一発でExcelワークシートに転記できる
とのことで、「あ、その手があったか」と。
クラスのプロパティを配列変数のように扱えないのなら、クラス内の配列変数（「今回の場合はtableArray_()」）を返り値にするメソッドを作ればいいわけだ。
そこで、次のようなメソッドを作った。
リスト２
Public Function getArray() As Variant '……(*)'
If hasArray_ = True Then
getArray = tableArray_
End If
End Function
(*)では、返り値の型をVariantにしている。要素数がその都度異なるので、Variantで受けるのが一番楽だと思った。
ちなみに、「hasArray_」という変数は、クラスのインスタンスが無事に表のデータを取得したらTrueにするように新たに持たせた変数。
必要なのかどうかよく分からなかったけど、一応持たせてみた。
動作確認
標準モジュールに下記のコードを書いて実行してみた。
Public Sub testTableArray()
Dim wtOperator As WordTableOperator
Set wtOperator = New WordTableOperator
wtOperator.createArrayFromTable 2, True
With wtOperator
ActiveSheet.Range("A1").Resize(.maxRow, .maxColumn).Value = .getArray
End With
End Sub
前回同様、
このWordドキュメントをアクティブにして実行。
実行結果
おおっ！ ちゃんとできとる！
これで、だいぶ転記の手間が省けるなあ。
おわりに
クラスのプロパティを配列そのものにするのは無理っぽいんですが、クラスの内部で保持している配列をそのまま返すようなメソッドを書けばいい、というのは素人にはなかなか出てこない発想でした。
id:mmYYmmdd さん、ありがとうございました!!!!!!!!
Wordの表の各セルの文字列を利用しやすくする(2)
クラスのプロパティに二次元配列を持たせてみる
表の内容をそのまま配列にする
「表」ということは、二次元配列と同じ形なんである。
そこで、
クラスのプロパティを二次元配列にする
ことを試みた。
クラスの改造
まず、前回記事のリスト１のうち、フィールド・アクセサ部分を以下のように書き換える。
リスト1-1
'フィールド'
Private wordApp_ As Word.Application
Private wordDoc_ As Word.Document
Private wordTable_() As Word.Table
Private tableArray_() As String '……(1)'
Private maxRow_ As Integer '……(2)'
Private maxColumn_ As Integer
Private isReady_ As Boolean
'アクセサ'
Public Property Get wordApp() As Word.Application
Set wordApp = wordApp_
End Property
Public Property Get wordDoc() As Word.Document
Set wordDoc = wordDoc_
End Property
Public Property Get wordTable(ByVal i As Integer) As Word.Table
Set wordTable = wordTable_(i)
End Property
Public Property Get tableArray(ByVal r As Integer, _
ByVal c As Integer) As String '……(3)'
tableArray = tableArray_(r, c)
End Property
Public Property Get maxRow() As Integer
maxRow = maxRow_
End Property
Public Property Get maxColumn() As Integer
maxColumn = maxColumn_
End Property
Public Property Get isReady() As Boolean
isReady = isReady_
End Property
(1)の
Private tableArray_() As String
では、新たにtableArray_()というString型の配列変数を準備。
さらに、(2)からの２行
Private maxRow_ As Integer Private maxColumn_ As Integer
でmaxRow_及びmaxColumn_という変数を準備した。この２つの変数には、取り扱うWordの表の行数と列数を格納する。
(3)の
Public Property Get tableArray(ByVal r As Integer, _
ByVal c As Integer) As String
tableArray = tableArray_(r, c)
End Property
は、tableArrayの値にアクセスするためのアクセサメソッド。
二次元の配列なので、引数が２つ必要。
そして、メソッドも１つ追加する。
リスト1-2
Public Sub createArrayFromTable(ByVal tableNum As Integer, _
ByVal hasHeader As Boolean) '……(1)'
On Error GoTo ErrorCatch
Dim startRow As Integer '……(2)'
If hasHeader = True Then startRow = 2
If hasHeader = False Then startRow = 1
With wordTable_(tableNum) '……(3)'
maxRow_ = .Rows.Count '……(4)'
maxColumn_ = .Columns.Count
ReDim tableArray_(maxRow_, maxColumn_) '……(5)'
Dim iRow As Integer '……(6)'
Dim iColumn As Integer
Dim str As String
Dim n As Integer
n = 1
For iRow = startRow To maxRow_ '……(7)'
For iColumn = 1 To maxColumn_ '……(8)'
str = .Cell(iRow, iColumn).Range.Text '……(9)'
tableArray_(n, iColumn) = Left(str, Len(str) - 2) '……(10)'
Next
n = n + 1 '……(11)'
Next
End With
Exit Sub
ErrorCatch:
End Sub
まずは(1)の
Public Sub createArrayFromTable(ByVal tableNum As Integer, _
ByVal hasHeader As Boolean)
でお分かりの通り、２つの引数を受け取るようにしている。
- 第１引数：Wordドキュメント内の表の番号
- 第２引数：１行目がラベル行なのかどうか
の２つを受け取って実行する。
(2)からの３行、
Dim startRow As Integer If hasHeader = True Then startRow = 2 If hasHeader = False Then startRow = 1
では、引数hasHeaderの値によって変数startRowの値を切り替えている。
たとえば、hasHeaderがTrueであるということは、表の１行目は項目ラベルだということだから、startRowを「2」にして、表の２行目から値を取得しよう、というわけ。
(3)で
With wordTable_(tableNum)
このようにしているので、この後、End WithまではwordTable_(tableNum)に格納されたTableオブジェクト、すなわち「tableNum番目の表」が処理の対象となる。
(4)からの２行、
maxRow_ = .Rows.Count maxColumn_ = .Columns.Count
では、TableオブジェクトのRows、ColumnsコレクションのCountプロパティを用いて、変数maxRow_、maxColumn_に表の行数・列数をセットしている。
(5)では、(4)で取得した表の行数・列数を用いて
ReDim tableArray_(maxRow_, maxColumn_)
tableArray_()をReDimしている。
さて、ここからがこのメソッドの中心。
まず、(6)からの５行、
Dim iRow As Integer '……(6)' Dim iColumn As Integer Dim str As String Dim n As Integer n = 1
は、変数の準備。
iRow
Forループ（外側）のカウンタとして使用。Wordの表の行数指定を兼ねる。
iColumn
Forループ(内側）のカウンタとして使用。配列二次元目のインデックス、及びWordの表の列数指定を兼ねる。
str
表の各セルの文字列の受け取りに使用。
n
配列一次元目のインデックスの指定に使用。
Wordの表から値を取得するとき、１行目が項目ラベルなのかどうかによって、１行目から値を取得しはじめる場合と２行目から値を取得しはじめる場合の２通りがあるので、Forループのカウンタ以外に別途Wordの表の行数を指定するための変数nを準備し、「1」で初期化している。
そして、このメソッドの処理の中心が(7)からの７行。
For iRow = startRow To maxRow_ '……(7)'
For iColumn = 1 To maxColumn_ '……(8)'
str = .Cell(iRow, iColumn).Range.Text '……(9)'
tableArray_(n, iColumn) = Left(str, Len(str) - 2) '……(10)'
Next
n = n + 1 '……(11)'
Next
Forループがネストしているので、ちょっと見づらいかも知れないが、行方向のループと列方向のループだけなので、許容範囲だと思う。
まず、(7)、
For iRow = startRow To maxRow_
行方向のループ指定だが、開始値を変数startRowにしているのがミソ。
言うまでもなく、表の１行目から読み取る場合と２行目から読み取る場合の２種類に対応するためだ。
次の(8)、
For iColumn = 1 To maxColumn_
は、列方向のループ。各行につき、１列目から右へ右へと値を取得しては配列に格納していく、というイメージ。
(9)の
str = .Cell(iRow, iColumn).Range.Text
で、セルの文字列をstrに格納し、
(10)の
tableArray_(n, iColumn) = Left(str, Len(str) - 2)
で「ハナクソ」と改行文字を除去した上で配列にセットしている。
１行分セットし終えたら、すなわち、(8)のForループが完了したら、次の行に進むために、(11)の
n = n + 1
で変数nをインクリメントする。
このようにすれば、表内の全ての値が配列tableArray_()セットされるはずだ。
動作確認
このクラスの動作確認用に、次のコードを標準モジュールに書く。
リスト２
Public Sub testTableArray()
Dim wtOperator As WordTableOperator
Set wtOperator = New WordTableOperator
wtOperator.createArrayFromTable 2, True '……(1)'
Dim iRow As Integer
Dim iColumn As Integer
With wtOperator '……(2)'
For iRow = 1 To .maxRow
For iColumn = 1 To .maxColumn
ActiveSheet.Cells(iRow, iColumn).Value = _
.tableArray(iRow, iColumn)
Next
Next
End With
Debug.Print wtOperator.tableArray(3, 3) '……(3)'
End Sub
(1)の
wtOperator.createArrayFromTable 2, True
では、createArrayFromTableメソッドを、引数「2」と「True」の２つを渡して実行。
日本語訳すると、「２番目の表の値を、１行目が項目ラベルであるとみなして二次元配列としてプロパティに格納せよ」ぐらいか。
(2)からの８行（正味７行）、
With wtOperator
For iRow = 1 To .maxRow
For iColumn = 1 To .maxColumn
ActiveSheet.Cells(iRow, iColumn).Value = _
.tableArray(iRow, iColumn)
Next
Next
End With
は、もはや説明不要だろう。
二重のForループを用いて、tavleArrayプロパティにセットした値をアクティブシートに書き込んでいるだけだ。
あと、(3)の
Debug.Print wtOperator.tableArray(3, 3)
は、二次元のインデックスを渡して値を取得する例。
実行結果
このWordドキュメントがアクティブの状態で実行した。
Excelシート上に各値が転記されている。
イミディエイト・ウインドウには、２番目の表の３行３列目の値が表示されている。
おわりに
せっかく二次元配列として表のデータを取得しているのだから、tableArrayプロパティに表のデータを読み込ませた後、
With wtOperator
ActiveSheet.Range("A1").Resize(.maxRow, .maxColumn).Value = .tableArray
End With
とでも書けば、一発でExcelワークシートに転記できそうなものだが、
こんなふうにコンパイル・エラーになって、実行すらさせてくれない。
プロパティはあくまでもプロパティであって、配列変数ではない、ということなのかなあ？
