読者です 読者をやめる 読者になる 読者になる

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

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

プロシージャの構成

ざっとこんな感じ。

ソースコード

リスト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

セル内のアンダーライン部分のみフォントを変える

文字列のうち、アンダーライン部分のフォントだけを変える

ツイッターのフォロワーさんの「漢字テストの問題をランダムに作成できんかなー」みたいなツイートに反応して、どうやったらできるのか考えてみた。

傍線部分だけゴシックにしないといけない

文字列に下線(傍線)を引くのは自動化できないにしても、下線部だけを狙い撃ちでフォントを変えるというのは、手作業でやると死ぬほどめんどくさい。

しかし、普段文字単位で書式をいじくることなんて皆無だから、どうしていいのか分からなかった。んで、調べてみると、Charactersオブジェクトを取得して書式を施せばよいと分かった。

参考

Characters オブジェクトを使用すると、文字列のうちの一部だけを対象にした修正ができます。

Characters オブジェクトを取得するには、Characters(start, length) プロパティを使用します。引数 start には開始する文字の先頭位置の番号を指定します。引数 length には、文字数を指定します。

ということなので、なんとかなりそう。

考え方

次のような考え方でコードを書くことにした。

  1. 1文字目から順番にチェックする
  2. 初めてアンダーラインのある文字にぶつかったときにフラグを立て、何文字目かを変数tmpStartに記録する
  3. アンダーラインのない文字にぶつかったら、何文字目かを変数tmpEndに記録してループを抜ける
  4. Charactersオブジェクトの引数startにtmpStartを、引数lengthにtmpEnd - tmpStartを渡すと、アンダーライン部分のCharactersオブジェクトが取得できる
  5. 後は、4.で得られたCharactersオブジェクトのFontプロパティをあれこれいじくる

と、こんな感じ。

実装

リスト1
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にして呼び出され専用にしてある。引数で渡している処理対象セルやフォント名を決め打ちにしてやれば、単独のプロシージャとしても使えると思う。

実行結果

f:id:akashi_keirin:20170514141152j:plain

明朝体の「ケイオウカク」のところだけが、

f:id:akashi_keirin:20170514141156j:plain

無事にゴシック体になった。

おわりに

Charactersオブジェクトをうまく使えば、Excelのセル内の文字列に関するしちめんどくさい作業のかなりの部分を軽減できるようになるかも知れない。

いづれは、クラスを作って手軽に扱えるようにしてみたい。

@akashi_keirin on Twitter

重複のない乱数発生のアルゴリズムを考えてみた

重複のない乱数を作る

重複のない乱数を発生させるアルゴリズムを考えてみた。まあ、ちょこっとggったらスマートなやつが見つかるとは思ったけど、自分で考えるというのが大事だと思ったのですよ。

素人丸出しのやり方なので、笑ってくれたらいいと思います。

考え方

ちょこっと作戦を考えてみた。

たとえば、1~10までの乱数を作るだけなら、Rnd関数を用いて、

Int(Rnd * 10) + 1

とでもすればよかろう。

問題は、これだけだと同じ数が出てきてしまうことだ。

順番をランダムに変えたいようなとき、これでは困る。

そこで、次のような手順を考えた。

  1. 10個の値を格納することができる配列を準備する
  2. 乱数を発生させる
  3. (2回目以降)発生させた値を、それまでに格納した全ての値と比べる
  4. 同じ値にぶつかったら、乱数発生をやり直して3.に戻る
  5. 一度も同じ値にぶつからずに3.を終えると、新たに配列に追加する
  6. 2.に戻る

このやり方でできると思った。

実装

リスト1
  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)からの2行、

Dim qNumbers() As Integer
ReDim qNumbers(1 To cnt)

では、作成した乱数を格納する配列を用意し、要素数でReDimしている。cntというのは、要素数が入っている変数だと思ってください。

(2)の

qNumbers(i) = Int(Rnd * cnt) + 1

で、1~10までの数を1つ作り、ひとまず配列qNumbersに格納。

一旦(3)で

hasDone = True

としてフラグ用の変数をTrueにしておく。

すでに取得済みの数と比較する必要があるのは、ループの2回目以降なので、(4)の

If i > 1 Then

で、ループの1回目のみ(5)以下のForループを飛ばすようにした。

(5)以下の6行、

For n = 1 To i - 1                  '……(5)'
  If qNumbers(i) = qNumbers(n) Then
    hasDone = False
    Exit For
  End If
Next

が重複を防ぐためのロジック。

Forループの最終値を「i - 1」にしておかないと無限ループになるので注意w(←経験者)

1つ手前までのqNumbersの全ての要素と比較し、同じ値があったら即hasDoneをFalseにしてループを抜けるようにした。

従って、このループを無事抜けるということは、重複のない値がセットされていて、hasDoneがTrueになっているということ。

(6)では、Doループの繰り返し条件としてhasDone = Falseを指定しているので、重複のない値が取得できていないときはDoループの先頭に戻って値を取得しなおすことになる。

実行結果

cntを10にして、リスト1

For i = 1 To cnt
  debug.Print qNumbers(i)
Next

を付け加えて実行してみると、

f:id:akashi_keirin:20170514134531j:plain

無事に重複なく1~10の数字が格納されていることが分かる。

おわりに

重複のない乱数の取得なんていうのは、さんざん考え尽くされた類のものだと思うので、もっとエレガントかつスマートなやり方があると思う。

もう少し仕事に余裕があったら、本格的にアルゴリズムの勉強をするんだけどなあ。

@akashi_keirin on Twitter

マクロなし縛りでドロップダウンリストの項目を切り替える

マクロなし縛りでドロップダウンリスト項目を動的に切り替える

「マクロなし縛り」でExcelでの様式づくりをせざるを得なくなったので、久しぶりに関数であれこれやってみた。

ろくにワークシート関数も覚えていないのにマクロを覚えてしまったために、「欲しい機能は自分で作る」みたいになっていた。達人が見たら「そんなもん、ワークシート関数使ったら一発やろがぼけー」状態だったかも知れん。

せっかくの機会なので、ちょっとまじめにExcelのワークシート関数を使ってみた。

「データの入力規則」リストの切り替え

ユーザに変なデータ入力をさせないために、よくお世話になる「データの入力規則」。

特に、ドロップダウンリストで項目を選択させることのできる「リスト」機能は重宝する。

このリストの項目を条件によって切り替える、ということをやってみた。

準備

f:id:akashi_keirin:20170513203350j:plain

ワークシート上に、リスト用の表を2つ作る。

f:id:akashi_keirin:20170513203356j:plain

1つ目のリストには「フラワーライン」と名前を定義し、

f:id:akashi_keirin:20170513203535j:plain

2つ目のリストには「反フラワー」と名前を定義しておく。

INDIRECT関数

んで、

名前だけは知っていたけど使ったことなかったExcel関数選手権

でもやったら結構いいところまで行くんじゃないか、と個人的には思っているINDIRECT関数ですよ。

基本的には、

=INDIRECT(セル番地)

の形で、セル参照を返してくれるという関数。

たとえば、

f:id:akashi_keirin:20170513203632j:plain

こんなふうに、K5セルに「デコスケ」と入力されているときに、

=INDIRECT("K5")

を計算すると、

f:id:akashi_keirin:20170513203642j:plain

こんなふうにK5セルの値が返る。

ということは、INDIRECT関数に渡す引数を切り替えてやれば、リスト項目を切り替えることができるということになる。

「データの入力規則」の設定

f:id:akashi_keirin:20170513203507j:plain

「元の値」のところを、

=INDIRECT($E$1)

にして、E1セルに「フラワーライン」と入力すると、

f:id:akashi_keirin:20170513203552j:plain

リスト項目はこの通り。

E1セルに「反フラワー」と入力すると、

f:id:akashi_keirin:20170513203617j:plain

リスト項目が変わった。

おわりに

入力された値に応じて動的に何かを切り替える、となると、安易にWorksheetのイベントマクロなんかで済ませようと考えがちだけれど、たまに「マクロなし縛り」という状況に追い込んでみると

名前は知っていたけど使ったことなかったExcel関数

が使えるようになるきっかけになるかも知れない、と思いました。

ワークシート関数もしっかりマスターしないといけないなあ。

@akashi_keirin on Twitter

文字列の中の必要な部分にだけ書式設定をする

指定した文字の書式だけを変更する

記入見本作り

記入例を作りたかったんだが、日付の欄は、

f:id:akashi_keirin:20170507184321j:plain

こんな感じで、「月」と「日」と「(」、「)」をあらかじめ入れておいて、月・日・曜日だけを書いてもらうようにしている。

んで、記入者に書いてもらう部分だけを手書き風のフォントに変えて記入例を作ろうと思った。

しかし、ちょっと考えたら分かると思うが、これはめんどくさい。

たとえば、
7月23日(日)
という記入例を作ろうと思ったら、
「7」と「23」と「日」(曜日の方)だけを選択してフォントを変える
というしちめんどくさいことになる。

まあ、ちまちまと時間をかけて努力するのが好きな人ならそれほど苦痛ではないだろうが、私にとっては端的に苦痛ですw

んで、WordVBAの練習も兼ねてやってみた。

必要な部分だけ書式を変更するマクロ

Wordのオブジェクト構造がイマイチよく分かっとらんので、かなり行き当たりばったりのコードだと思うが、恥ずかしげもなく載せる。

リスト1
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オブジェクトを取得している。

んでもって、次の2行、

.Name = FONT_TO_USE
.Italic = True

でフォントの種類と斜体を設定する。

この処理を、それぞれの文字に対して実行するかどうかを切り替える、というやり方をしている。

ちなみに、「FONT_TO_USE」というのは定数で、リスト1の(1)で

Public Const FONT_TO_USE As String = "HG正楷書体-PRO"

と指定している。

(2)からの4行は、変数の宣言。

chr

Charactersコレクションから取得した1文字を入れる。(*)の処理を施すかどうかの条件判定に使用。別になくても良いが、コードを短くするために使っている。

i

おなじみループカウンタ。

numOfChar

選択中の文字数を格納する。Forループの上限値として使用。

flg

(*)の処理を行うかどうかを切り替えるためのフラグ。

(3)の

numOfChar = Selection.Range.Characters.Count

では、CharactersコレクションのCountプロパティを用いて文字数を取得し、変数numOfCharに格納。

ここからがForループの中身。

まず、(4)の

chr = Selection.Range.Characters(i)

で1文字を変数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

は、一番初歩的な条件設定。

「月」、「日」、「(」、「)」だったら何もしない、ということ。

ただし、めんどくさいのは、(*)の処理を施したい対象の中にも「月」、「日」という文字があること。言うまでもなく曜日を表す方の「月」、「日」だ。

幸い、曜日を表す方の「月」、「日」には、
「()」で括られている
という特徴があるので、
「(」に出会ったらスイッチオン、「)」に出会ったらスイッチオフ
というやり方にした。

……と書いているうちに、
カッコで括られているのは1文字って決まってるんだから、「(」に出会って次の1字に(*)の処理を施したら即flgをFalseにしたらいいんじゃね???
と思いついたというのは内緒だw

(7)、(8)の

If chr = "(" Then flg = True
If chr = ")" Then flg = False

がスイッチ切り替え。

「(」に出会ったらスイッチオン、「)」に出会ったらスイッチオフ、というイメージ。

実行結果

f:id:akashi_keirin:20170507184325j:plain

こんなふうに、日付欄を選択して実行すると、

f:id:akashi_keirin:20170507184330j:plain

この通り、意図したとおりの結果となった。

おわりに

ツッコミどころ満載のコードだということは認めます。

正直、Wordのオブジェクト構造がイマイチ理解できていないので、アホみたいなコードになっていると思います。これを機に勉強しようとは思うものの、ホントにやるかどうかは分かりませんw

ただ、ちょい書きでこのぐらいできたら、しちめんどくさい作業をせずに済む(しかも、コードを書くのは楽しいので、しょうもないはずの作業が楽しくなる)ので、まあええかな、と。

@akashi_keirin on Twitter

Wordの表の各セルの文字列を利用しやすくする(3)

WordTableCreatorクラスの修正

id:mmYYmmdd さんからのコメント

akashi-keirin.hatenablog.com

前回の記事に、id:mmYYmmdd さんからコメントをいただいた。

全く以て仰せのとおり、というところなので、アドヴァイスに沿ってコードを修正する。

雑な配列の定義を改める

まずは、

ReDim tableArray_(1 To maxRow_, 1 To maxColumn_) とするかクラスモジュールの先頭に Option Base 1 を宣言するかしないと0番目の要素が余分になってしまいます

正直、配列を使い始めたのが割と最近だったもので、扱いが雑でした。「動きゃいい」という感覚でやっていたことは否めません。やはり、きっちりとしないといけませんな。

というわけで、二次元配列の要素数が確定した後、ReDimするところを次のように訂正する。

リスト1
ReDim tableArray_(1 To maxRow_, 1 To maxColumn_)

表のセル番地との対応を優先して1始まりにしたんですが、後々のことを考えたら0始まりの方がいいのかも……。このあたりは経験不足で何とも……。

配列をまるごと取り出すメソッドの導入

こちらについては、

テーブル丸ごと出力する関数を用意すれば一発でExcelワークシートに転記できる

とのことで、「あ、その手があったか」と。

クラスのプロパティを配列変数のように扱えないのなら、クラス内の配列変数(「今回の場合はtableArray_()」)を返り値にするメソッドを作ればいいわけだ。

そこで、次のようなメソッドを作った。

スト2
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

前回同様、

f:id:akashi_keirin:20170507153834j:plain

このWordドキュメントをアクティブにして実行。

実行結果

f:id:akashi_keirin:20170507153842j:plain

おおっ! ちゃんとできとる!

これで、だいぶ転記の手間が省けるなあ。

おわりに

クラスのプロパティを配列そのものにするのは無理っぽいんですが、クラスの内部で保持している配列をそのまま返すようなメソッドを書けばいい、というのは素人にはなかなか出てこない発想でした。

id:mmYYmmdd さん、ありがとうございました!!!!!!!!

@akashi_keirin on Twitter

Wordの表の各セルの文字列を利用しやすくする(2)

クラスのプロパティに二次元配列を持たせてみる

表の内容をそのまま配列にする

「表」ということは、二次元配列と同じ形なんである。

そこで、
クラスのプロパティを二次元配列にする
ことを試みた。

クラスの改造

まず、前回記事のリスト1のうち、フィールド・アクセサ部分を以下のように書き換える。

リスト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)からの2行

Private maxRow_ As Integer
Private maxColumn_ As Integer

でmaxRow_及びmaxColumn_という変数を準備した。この2つの変数には、取り扱うWordの表の行数と列数を格納する。

(3)の

Public Property Get tableArray(ByVal r As Integer, _
                               ByVal c As Integer) As String
  tableArray = tableArray_(r, c)
End Property

は、tableArrayの値にアクセスするためのアクセサメソッド。

二次元の配列なので、引数が2つ必要。

そして、メソッドも1つ追加する。

リスト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) 

でお分かりの通り、2つの引数を受け取るようにしている。

  • 第1引数:Wordドキュメント内の表の番号
  • 第2引数:1行目がラベル行なのかどうか

の2つを受け取って実行する。

(2)からの3行、

Dim startRow As Integer
If hasHeader = True Then startRow = 2
If hasHeader = False Then startRow = 1

では、引数hasHeaderの値によって変数startRowの値を切り替えている。

たとえば、hasHeaderがTrueであるということは、表の1行目は項目ラベルだということだから、startRowを「2」にして、表の2行目から値を取得しよう、というわけ。

(3)で

With wordTable_(tableNum)

このようにしているので、この後、End WithまではwordTable_(tableNum)に格納されたTableオブジェクト、すなわち「tableNum番目の表」が処理の対象となる。

(4)からの2行、

maxRow_ = .Rows.Count
maxColumn_ = .Columns.Count

では、TableオブジェクトのRows、ColumnsコレクションのCountプロパティを用いて、変数maxRow_、maxColumn_に表の行数・列数をセットしている。

(5)では、(4)で取得した表の行数・列数を用いて

ReDim tableArray_(maxRow_, maxColumn_)

tableArray_()をReDimしている。

さて、ここからがこのメソッドの中心。

まず、(6)からの5行、

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の表から値を取得するとき、1行目が項目ラベルなのかどうかによって、1行目から値を取得しはじめる場合と2行目から値を取得しはじめる場合の2通りがあるので、Forループのカウンタ以外に別途Wordの表の行数を指定するための変数nを準備し、「1」で初期化している。

そして、このメソッドの処理の中心が(7)からの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にしているのがミソ。

言うまでもなく、表の1行目から読み取る場合と2行目から読み取る場合の2種類に対応するためだ。

次の(8)、

For iColumn = 1 To maxColumn_

は、列方向のループ。各行につき、1列目から右へ右へと値を取得しては配列に格納していく、というイメージ。

(9)の

str = .Cell(iRow, iColumn).Range.Text

で、セルの文字列をstrに格納し、

(10)の

tableArray_(n, iColumn) = Left(str, Len(str) - 2)

で「ハナクソ」と改行文字を除去した上で配列にセットしている。

1行分セットし終えたら、すなわち、(8)のForループが完了したら、次の行に進むために、(11)の

n = n + 1

で変数nをインクリメントする。

このようにすれば、表内の全ての値が配列tableArray_()セットされるはずだ。

動作確認

このクラスの動作確認用に、次のコードを標準モジュールに書く。

スト2
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つを渡して実行。

日本語訳すると、「2番目の表の値を、1行目が項目ラベルであるとみなして二次元配列としてプロパティに格納せよ」ぐらいか。

(2)からの8行(正味7行)、

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)

は、二次元のインデックスを渡して値を取得する例。

実行結果

f:id:akashi_keirin:20170506201246j:plain

このWordドキュメントがアクティブの状態で実行した。

f:id:akashi_keirin:20170506201252j:plain

Excelシート上に各値が転記されている。

f:id:akashi_keirin:20170506201255j:plain

イミディエイト・ウインドウには、2番目の表の3行3列目の値が表示されている。

おわりに

せっかく二次元配列として表のデータを取得しているのだから、tableArrayプロパティに表のデータを読み込ませた後、

With wtOperator
  ActiveSheet.Range("A1").Resize(.maxRow, .maxColumn).Value = .tableArray
End With

とでも書けば、一発でExcelワークシートに転記できそうなものだが、

f:id:akashi_keirin:20170506201258j:plain

こんなふうにコンパイル・エラーになって、実行すらさせてくれない。

プロパティはあくまでもプロパティであって、配列変数ではない、ということなのかなあ?

@akashi_keirin on Twitter