範囲内でのセルの相対位置を求める

セルの範囲内での相対位置を求める

特定のセルが、指定範囲内の上から何番目にあるのかを求める必要があったので作った。

「指定範囲」は1列、「特定のセル」は1個限定。

セルの相対位置を返すFunction

とりあえず、指定範囲を上から順に当たっていって、対象のセルの位置を見つけたときの順番を表す数を返したらいいと思った。

リスト1 標準モジュールRangeUtil
Public Function getRelativePosition( _
                  ByVal TargetRange As Range, _
                  ByVal Target As Range) As Long  '……(1)'
  Dim ret As Long
  ret = 0
  'Guard clause'
  If TargetRange.Columns.Count > 1 Then GoTo Finalizer  '……(2)'
  If Target.Count > 1 Then GoTo Finalizer
  Dim rng As Range
  Set rng = Application.Intersect(TargetRange, Target)
  If rng Is Nothing Then GoTo Finalizer
  
  'Main process'
  Dim i As Long
  Dim addressStr As String
  For i = 1 To TargetRange.Rows.Count  '……(3)'
    If TargetRange.Cells(i, 1).Address = Target.Address Then
      ret = i
      Exit For
    End If
  Next
  
  'Return value'
Finalizer:
  getRelativePosition = ret
End Function

まず、(1)の

Public Function getRelativePosition( _
                  ByVal TargetRange As Range, _
                  ByVal Target As Range) As Long

で引数と返り値の設定。

引数TargetRangeでセル範囲を受け取り、引数Targetで位置を調べる対象のセルを受け取る。

ちなみに、引数名の記法はパスカル記法にした。組み込みの引数名とかぶらないように考えるのがめんどくさくなったから。

そのうち、メソッド名もパスカル記法に変える日が来ると思う。いまのところキャメル記法だけど。

(2)からの5行、

If TargetRange.Columns.Count > 1 Then GoTo Finalizer
If Target.Count > 1 Then GoTo Finalizer
Dim rng As Range
Set rng = Application.Intersect(TargetRange, Target)
If rng Is Nothing Then GoTo Finalizer

はガード節。

セル範囲が2列以上あるとき、位置を調べる対象セルが2個以上あるとき、セル範囲内に位置を調べる対象セルがないとき、にそれぞれ「0」を返すようにした。

(3)からの6行、

For i = 1 To TargetRange.Rows.Count
  If TargetRange.Cells(i, 1).Address = Target.Address Then
    ret = i
    Exit For
  End If
Next

が位置を調べる処理。

1からセル範囲の行数分だけループして、セルのアドレスが一致した時点でループを抜ける。

その時点での変数iの値が、〝上から何番目かを表す値〟になっているはず。

使ってみる

まず、

f:id:akashi_keirin:20201018090205j:plain

こんなセル範囲を用意する。

A1セル~A14セルまでの範囲に、「TargetRange」という名前が付けてある。

こうしておいて、次のコードで実験してみる。

スト2 標準モジュールModuleMain
Private Sub detectRelativePosition()
  Dim relPos As Long
  relPos = RangeUtil.getRelativePosition( _
                       TargetRange:=Sh01.Range("TargetRange"), _
                       Target:=Selection)
  If relPos < 1 Then
    Call Provoke.makeUserSick( _
                   Message:="選択箇所がおかしいわボケwww", _
                   MsgBoxIcon:=mbiCritical, _
                   Title:="残念www")
    Exit Sub
  End If
  Call Provoke.makeUserSick( _
                 Message:="お前が選んだセルは、範囲内の上から" & _
                          CStr(relPos) & "番目やwww。", _
                 MsgBoxIcon:=mbiInformation, _
                 Title:="選択セルの範囲内相対位置を調べた結果www")
End Sub

選択しているセルが、「TargetRange」と名付けたセルの上から何番目にあるのかを、ちょっと腹の立つメッセージボックスで表示するというだけのプログラム。

ちなみに、コード中のProvokeというのは標準モジュールの名前で、その中にmakeUserSickというメソッドを書いている。(標準モジュールProvoke内のコードは後掲する。)

こいつを、

f:id:akashi_keirin:20201018090209j:plain

こんなふうに配置したコマンドボタンに登録して使う。

動作風景

f:id:akashi_keirin:20201018090213g:plain

こんな風に動作する。

おわりに

もしかして、セル範囲内の相対位置を返す組み込みの関数とかそういうのがあったりするんでしょうか?

標準モジュールProvoke
Option Explicit

Public Enum MsgBoxIcon
  mbiCritical = vbCritical
  mbiExclamation = vbExclamation
  mbiInformation = vbInformation
  mbiQuestion = vbQuestion
End Enum

'///ち~んw用'
Private Const MAKE_USER_SICK_2013 As String = _
              "       _______" & vbCrLf & _
              "   /       \" & vbCrLf & _
              "/ /・\  /・\ \" & vbCrLf & _
              "|   ̄ ̄    ̄ ̄   |   ち~んw" & vbCrLf & _
              "|    (_人_)   |" & vbCrLf & _
              "|     \  |   |" & vbCrLf & _
              "\     \_|  /"

Private Const MAKE_USER_SICK_2010 As String = _
              "     _______" & vbCrLf & _
              " /               \ " & vbCrLf & _
              "/ /・\  /・\     \" & vbCrLf & _
              "|   ̄ ̄    ̄         | ち~んw" & vbCrLf & _
              "|    (_人_)       |" & vbCrLf & _
              "|     \     |          |" & vbCrLf & _
              "\      \_|       /"

'///ユーザーを煽るAAを表示する'
Public Sub makeUserSick( _
               Optional ByVal Message As String, _
               Optional ByVal MsgBoxIcon As MsgBoxIcon, _
               Optional ByVal Title As String)
  If Message = "" Then Message = "涙拭けよwww"
  Dim ver As String
  ver = Application.Version
  Dim str As String
  Select Case ver
    Case "14.0"
      str = MAKE_USER_SICK_2010
    Case "15.0"
      str = MAKE_USER_SICK_2013
    Case "16.0"
      str = MAKE_USER_SICK_2013
    Case Else
      str = MAKE_USER_SICK_2010
  End Select
  Call MsgBox(Prompt:=Message & vbCrLf & str, _
              Buttons:=MsgBoxIcon, _
              Title:=Title)
End Sub

 

VBAでWordドキュメントに行番号を振る

VBAでWordドキュメントに行番号を振る

最近、〈脱・パワポ運動〉の一環として、説明用資料の類をWordで作成するようにしています。

パワポで作るいわゆる「ポンチ絵」のわかりにくさ/非効率を解消するのが目的です。

Wordで作成したドキュメントの「参照指示性」を劇的に上げるための方法が、『シラバス論』の著者、芦田宏直氏が発明した、〈Wordで作成したドキュメント全体に通しで行番号を振る〉というものです。

これ、アホみたいに簡単なんですけど、効果は絶大!

お試しあれ。

文書全体に通しで行番号を振る

これは、めっちゃ簡単。

f:id:akashi_keirin:20200918082851j:plain

こういう、ごく普通の文書があるとする。

f:id:akashi_keirin:20200918082856j:plain

「ページ レイアウト」タブから

f:id:akashi_keirin:20200918082859j:plain

「行番号」を選択し、

f:id:akashi_keirin:20200918082903j:plain

「連続番号」を選択すると、

f:id:akashi_keirin:20200918082909j:plain

ほれ、このとおり、通しの行番号が振られる。

めちゃくちゃ簡単。たったこれだけのことで、資料の「参照指示性」は飛躍的に高まる。「(○ページの)〇〇行目のところを話しますね。」で済む。

パワポポンチ絵だとこうはいかない。「えっと、○ページの左上のコマの真ん中やや右のあたりに……」みたいになってわけがわからなくなる。

LineNumberingオブジェクト

この行番号機能を司るのは、VBAの場合、「LineNumberingオブジェクト」というらしい。

「Word2013 developer docs」(Word2013のオフラインヘルプ)によると、

LineNumbering Object (Word)

Represents line numbers in the left margin or to the left of each newspaper-style column.

Remarks

Use the LineNumbering property to return the LineNumbering object. The following example applies line numbering to the text in the first section of the active document.

VBA
With ActiveDocument.Sections(1).PageSetup.LineNumbering 
 .Active = True 
 .CountBy = 5 
 .RestartMode = wdRestartPage 
End With

The following example applies line numbering to the pages in the current section.

VBA
Selection.PageSetup.LineNumbering.Active = True

ということらしい。

どうやら、[Document].[Section].PageSetupオブジェクトのLineNumberingを参照したら得られるLineNumberingオブジェクトが司っているものらしい。

LineNumberingオブジェクトには、八つのプロパティがある。

同じく「Word2013 developer docs」によると、

Name Description
Active True if line numbering is active for the specified document, section, or sections. Read/write Long.
Application Returns an Application object that represents the Microsoft Word application.
CountBy Returns or sets the numeric increment for line numbers. Read/write Long.
Creator Returns a 32-bit integer that indicates the application in which the specified object was created. Read-only Long.
DistanceFromText Returns or sets the distance (in points) between the right edge of line numbers and the left edge of the document text. Read/write Single.
Parent Returns an Object that represents the parent object of the specified LineNumbering object.
RestartMode Returns or sets the way line numbering runs -- that is, whether it starts over at the beginning of a new page or section or runs continuously. Read/write WdNumberingRule.
StartingNumber Returns or sets the starting line number. Read/write Long.

となっている。

総行番号にする場合だと、

  • StartingNumberプロパティを1に、
  • CountByプロパティを1に、
  • RestartModeプロパティをwdRestartContinuousに、
  • ActiveプロパティをTrue

したらよさげ。

ドキュメントに総行番号を振るコード

ThisDocumentに総行番号を振るだけのコードを示す。

リスト1 標準モジュール
Private Sub activateLineNumbering()
  Dim lnNumbering As LineNumbering    '……(*)'
  Set lnNumbering = ThisDocument.Sections(1).PageSetup.LineNumbering
  With lnNumbering
    .StartingNumber = 1
    .CountBy = 1
    .RestartMode = wdRestartContinuous
    .Active = True
  End With
End Sub

通常、(*)のところは、オフラインヘルプのサンプルコードのように

With ThisDocument.Sections(1).PageSetup.LineNumbering

とでも書くのだろうけれど、「LineNumberingオブジェクトを使っているんだ!」という意識を高めるために(笑)、あえて変数に突っ込んで使っている。

ちなみに、ActiveプロパティがなんでBoolean型でなくてLong型なのかはわからん。

実行

リスト1を実行してみる。

f:id:akashi_keirin:20200918082915j:plain

この状態で実行すると、

f:id:akashi_keirin:20200918082919j:plain

f:id:akashi_keirin:20200918082925j:plain

バッチリ。

おわりに

これで、たくさんのWordドキュメントに一気に行番号表示させることができる。

Rangeオブジェクトの終端があるParagraphオブジェクトのインデックス番号を返すFunction(Word)

Rangeオブジェクトの終端があるParagraphオブジェクトのインデックス番号を返すFunction

更新頻度ガタ落ちですが、またしてもWordVBAネタです。

まずはコードを

お急ぎの方は、コードをコピッペして使ってください。

リスト1
Public Function getParagraphIndex( _
            ByVal tgtRange As Range) As Long
  Dim ret As Long
  tgtRange.Start = 0
  ret = tgtRange.Paragraphs.Count
  getParagraphIndex = ret
End Function

たったこんだけ。正味2行w

まさかこんなに簡単にできるとは思っていませんでした。

使ってみる

たとえば、テキトーなドキュメントを用意して、

f:id:akashi_keirin:20200704095029j:plain

こんなふうにテキトーに範囲を選択しておく。

画像では、4~5段落にまたがった範囲を選択している。

で、イミディエイト・ウィンドウに次のコードを書いて[Enter]を押す。

?getParagraphIndex(Selection.Range)

すると、

f:id:akashi_keirin:20200704095032j:plain

ちゃんと「5」が出力されておる。

バッチリ!

解説

こんなしょうもないコードだが、二つも発見があった。

短いコードなので再掲する。

リスト1(再掲)
Public Function getParagraphIndex( _
            ByVal tgtRange As Range) As Long
  Dim ret As Long
  tgtRange.Start = 0  '……(1)'
  ret = tgtRange.Paragraphs.Count  '……(2)'
  getParagraphIndex = ret
End Function

Start(End)プロパティはRead/Writeだった

これは、完全に思い込み。

勝手にRead onlyだと固く信じて疑っていなかった。

Microsoft Docsの「Range.Start Property」の項にも、

Range.Start property (Word)

Returns or sets the starting character position of a range. Read/write Long.

と明記してあるし。

(1)の

tgtRange.Start = 0

によって、tgtRangeが指し示すRangeオブジェクトの始端をドキュメントの先頭にしているわけだ。

RangeオブジェクトにもParagraphsコレクションがある

これも全然知らなかった。

Paragraphs」というぐらいだからてっきりDocumentオブジェクトの直参だと思っていた。

これまた、Microsoft Docsの「Range.Paragraphs Property」の項にはっきりと

Range.Paragraphs property (Word)

Returns a Paragraphs collection that represents all the paragraphs in the specified range. Read-only.

と書いてある。

つまり、(1)を実行した段階で、tgtRangeが指し示すRangeオブジェクトの範囲は、〈ドキュメントの始端~選択範囲の終端〉になっているわけなので、(2)の

ret = tgtRange.Paragraphs.Count

によって、〈ドキュメントの始端~選択範囲の終端〉に含まれる段落数、すなわち選択範囲の終端がある段落が先頭から数えて何番目か、を表す数値が変数retに返る、というわけだ。

最初にこのアイディアを考えついたやつは天才だと思う。

おわりに

世の中、天才だらけでいやになるぜ。

参照元に参照先の通し行番号を書き込む(2)

参照元に参照先の通し行番号を書き込む(2)

たとえば、

f:id:akashi_keirin:20200607183745j:plain

みたいなドキュメントがあるとする。

参照指示性を高めるために、全ての行に通しで行番号を振っている。

これは、芦田宏直氏のアイディアで、詳しいことは氏の著書『シラバス論』(2019 晶文社)をご覧ください。

問題は、文中に「〇〇行目を参照」などと書いた場合。

「相互参照」機能を使えば、段落番号とかページ番号なんかは設定できるんだが、通しの行番号というのがない。

参照先の位置などというものは、編集の都合で揺れ動くものなので、「相互参照」的に設定できないのは非常につらい。

そこで、

akashi-keirin.hatenablog.com

このとき、ブックマークを利用して参照先の通しの行番号を割り出し、参照元の行番号の部分を書き換える方法を編み出した。

あとは、前回発覚した

ブックマーク部分の文字を書き換えたらブックマークが消滅する問題

を解消すればよろしい。

消滅するブックマークを復活させる考え方

まず、次のように考えた

  1. 参照元[Range].Textを書き換える前に、参照元Rangeオブジェクトを取得しておく
  2. 参照元[Bookmark].Range.Textを書き換える
  3. Document.Bookmarks.Addメソッドを、参照元のブックマーク名、1.で取得したRangeオブジェクトを渡して実行する

これでうまくいく、と思った。

しかし、これではうまくいかない。

2.で参照元[Bookmark].Range.Textを書き換えた時点で、1.で取得したRangeオブジェクトが潰れてしまっているのだ。

たとえば、「○行目」の「○」の部分(1文字選択の状態)だったはずのRangeオブジェクトが、2.で「48行目」というふうに書き換えたとすると、「48」の手前のカンチャン(0文字選択の状態)になってしまうのだ。

これではまずい。

そこで、次のような手順を踏むことにした。

  1. 参照元[Range].Textを書き換える前に、参照元Rangeオブジェクトを取得しておく
  2. 参照元[Bookmark].Range.Textを書き換える
  3. 1.で取得したRangeオブジェクトについてSelectメソッドを実行する。(書き換えた行番号の手前にカーソルが移動する。)
  4. Selection.MoveRightメソッドを用いて、行番号の文字数分だけカーソルを右に動かす。(右にドラッグする。)
  5. Document.Bookmarks.Addメソッドを、参照元のブックマーク名、4.で取得したSelection.Rangeオブジェクトを渡して実行する

こんなふうにした。

参照先の行番号に応じて参照元を書き換えるメソッド

上記の考えに基づいて作成したメソッドがコチラ。

リスト1
Public Sub refreshLineNumberReference( _
             ByVal TargetDocument As Document, _
             ByVal ReferrerName As String, _
             ByVal ReferenceName As String)
'### 参照先ブックマークのある行番号を取得して、参照元 ###'
'### ブックマークの箇所の行番号を書き換える           ###'
  '///ReferrerName  :参照元ブックマーク名'
  '///ReferenceName :参照先ブックマーク名'
  Dim Doc As Document
  Set Doc = TargetDocument
  '参照先、参照元ブックマークが存在しなかったらExit'
  If Not bookmarkExists(Doc, ReferenceName) Then Exit Sub
  If Not bookmarkExists(Doc, ReferrerName) Then Exit Sub
  'メインの処理'
  '参照元ブックマークを取得'
  Dim bmFrom As Bookmark
  Set bmFrom = Doc.Bookmarks(ReferrerName)
  '参照先の行番号を取得'
  Dim lineNum As Long
  lineNum = getLineNumber(Doc.Bookmarks(ReferenceName).Range)
  '参照元のRangeオブジェクトを取得'
  Dim tgtRange As Range
  Set tgtRange = bmFrom.Range
  '参照元の行番号を書き換える'
  Dim tmp As String
  tmp = CStr(lineNum)
  bmFrom.Range.Text = tmp
  '参照元ブックマークが消滅しているので、復元する'
  'Rangeオブジェクトが潰されてしまっているので、行番号を表す'
  '文字数分右に広げてRagneオブジェクトを取得し直す'
  Call tgtRange.Select
  Call Selection.MoveRight(wdCharacter, Len(tmp), wdExtend)
  Set tgtRange = Selection.Range
  '再度ブックマークを設定する'
  Call Doc.Bookmarks.Add(ReferrerName, tgtRange)
End Sub
Private Function bookmarkExists( _
             ByVal tgtDoc As Document, _
             ByVal tgtName As String) As Boolean
  '///ブックマーク名の存否を確認'
  bookmarkExists = True
  Dim i As Long
  For i = 1 To tgtDoc.Bookmarks.Count
    If tgtDoc.Bookmarks(i).Name = tgtName Then
      Exit Function
    End If
  Next
  bookmarkExists = False
End Function

Public Function getLineNumber( _
            ByVal tgtRange As Range) As Long
  Dim ret As Long
'///tgtRangeのあるページ番号を取得'
  Dim currPage As Long
  currPage = tgtRange.Information(wdActiveEndPageNumber)
  'tgtRangeのあるページ内での行番号を取得'
  Dim currLine As Long
  currLine = tgtRange.Information(wdFirstCharacterLineNumber)
  'tgtRangeが1ページ目にあるときは、その行番号を返す'
  If currPage = 1 Then
    ret = currLine
    GoTo Finalizer:
  End If
  '2ページ以上ある時は、手前のページまでの累計を足さなければいけない'
  Dim Doc As Document
  Set Doc = tgtRange.Parent
  'カーソル位置を記録'
  Dim orgRange As Range
  Set orgRange = Selection.Range
  '文書の先頭にカーソルを置く'
  Call Doc.Range(0, 0).Select
  '1ページ目の最終位置を取得'
  Dim pageEnd As Long
  '1ページ目の最終位置を選択'
  Dim i As Long
  For i = 1 To currPage - 1
    pageEnd = Doc.Bookmarks("\Page").End
    Call Doc.Range(pageEnd - 1, pageEnd - 1).Select
    ret = ret + Selection.Range.Information(wdFirstCharacterLineNumber)
    '次のページの先頭へ'
    Call Selection.MoveRight(wdCharacter, 1, wdMove)
  Next
  ret = ret + currLine
  'カーソル位置を戻す'
  Call orgRange.Select
Finalizer:
  getLineNumber = ret
End Function

Rangeオブジェクトのある通し行番号を返すメソッドのコードを再掲したので、異様にタテ長になってしまったが、気にしないでくだされ。

今回もかなり細かくコメントを入れたので、説明は省略。

使ってみる

f:id:akashi_keirin:20200607183748j:plain

f:id:akashi_keirin:20200607183751j:plain

このように、参照先と参照元にそれぞれ「参照先01」、「参照元01」という名前のブックマークを設定し、次のコードで使ってみる。

スト2
Private Sub test00()
  Dim Doc As Document
  Set Doc = Application.ActiveDocument
  Call LineNumUtil.refreshLineNumberReference( _
                     Doc, _
                     "参照元01", _
                     "参照先01")
End Sub

f:id:akashi_keirin:20200607183801g:plain

ほれ。このように、ちゃんと参照先の行番号に置き換わっておる。

f:id:akashi_keirin:20200607183818g:plain

さらに、参照先をテキトーに動かしてから実行しても、ちゃんと参照先の行番号に置き換わっておる。

おわりに

やはりWordのRangeオブジェクトは癖が強い。まだまだ理解が足りないな……。

もっとわかってきたら、洗練されてくると思う。

行高を適切に(?)調整する(Excel)

行高を適切に(?)調整する(Excel)

印刷時に行が切れてしまわないようにする方法を考えた。

考え方

フォントには、固有の行高がある。単位はポイント。で、Excelの行の高さ([Range].RowHeightプロパティの値)も単位はポイント。だから、次のような考え方で行けるはず。

  • フォントの固有の高さを求める
  • セルの中で一行あたり何文字になるのかを求める
  • セル内の文字数とか改行回数をもとに何行になるのかを求める
  • 上下の余白を何ポイント取るのか決める

まあ、これでよかろう。

フォントの固有の高さを求める

これは、よくわからんので、使いたいフォントを指定し、使いたいフォントサイズに変えて、行の境目をダブルクリックしてみた。

たとえば、「UD デジタル 教科書体 NK-R」で「11ポイント」を指定すると、

f:id:akashi_keirin:20200605181953j:plain

このように、行高は15ポイントになった。まあ、これでよかろう。(もし違っていたら教えろ教えてください。)

セルの中での一行あたり文字数を調べる

これは、どうすればよいか分からなかったので、数えたw

f:id:akashi_keirin:20200605181959j:plain

PDF化して、目視で数えましたとも。だいたい、55とか56とか、その辺w

セル内の文字数とか改行回数をもとに何行になるのかを求める

セル内改行がなかったら楽勝なんだが、セル内改行を加味するとなるとめんどくさい。

次のように考えた。

  • セル内に改行記号がなかったら、単純に(文字数 \ 一行あたり文字数) + 1でよい。
  • セル内に改行記号がある場合は、文字列を先頭からスキャンし、一行あたり文字数に達するか、改行文字にぶつかったらカウントアップする

こんな感じ。

「一行あたり文字数に達するか、改行文字にぶつかったらカウントアップする」という処理は、コードを示した方が早いので示す。

リスト1
Private Function getLinesCount( _
             ByVal tgtCell As Range) As Long
  Dim i As Long
  Dim ret As Long
  ret = 1
  Dim cnt As Long
  cnt = 0
  Dim tgtStr As String
  With tgtCell
    tgtStr = .Value
    For i = 1 To Len(tgtStr)
      cnt = cnt + 1
      '改行文字にぶつかったらcntをリセットして行数をイン'
      'クリメント'
      If Mid(tgtStr, i, 1) = vbLf Then
        cnt = 0
        ret = ret + 1
        GoTo Continue
      End If
      'cntが1行あたり文字数に達したらcntをリセットして'
      '行数をインクリメント'
      If cnt Mod chrCntPerLine = 0 Then
        cnt = 0
        ret = ret + 1
      End If
Continue:
    Next
  End With
    getLinesCount = ret
End Function

途中出てくるchrCntPerLineは、一行あたり文字数を入れておく変数。モジュールレベル変数にしているので、宣言がない。決してさんたろう方式ではないので誤解のなきよう。

上下の余白を何ポイント取るのか決める

「決める」といっても、上○ポイント、下○ポイントみたいに決めることは(たぶん)できないので、期待しないように。

垂直方向を中央揃えにしておけば、上下に均等にマージンを入れるぐらいならできる、という意味。

たとえば、行数 × 一行あたりの行高 で求めた値に10を足してやれば、上下5ポイントづつマージンができる。ただそれだけだ

行高を調整するメソッド

めんどくさいので完成したコードを示す。

スト2 標準モジュール RowHeightUtil
Option Explicit

'Module Level Variables'
Private fntHeight As Single
Private chrCntPerLine As Long
Private tpbtmMargin As Single

'Methods'
Public Sub adjustRowHeight(ByVal targetCell As Range, _
                           ByVal FontHeight As Single, _
                           ByVal CharCountPerLine As Long, _
                           ByVal TopBottomMargin As Single)
  If targetCell.Value = "" Then Exit Sub
  fntHeight = FontHeight
  chrCntPerLine = CharCountPerLine
  tpbtmMargin = TopBottomMargin
  Dim linesCount As Long
  Dim tgtRowHeight As Single
  With targetCell
    'セル内改行がされていなければ、文字数だけで行数を判定する'
    If InStr(1, .Value, vbLf) = 0 Then
      linesCount = (Len(.Value) \ chrCntPerLine) + 1
    'セル内改行があるときは、1文字づつスキャンして行数を判定する'
    Else
      linesCount = getLinesCount(targetCell)
    End If
    tgtRowHeight = (linesCount * fntHeight) + tpbtmMargin
    '親のWorksheetオブジェクトを取得'
    Dim tgtSh As Worksheet
    Set tgtSh = .Parent
    tgtSh.Rows(.Row).RowHeight = tgtRowHeight
  End With
End Sub

Private Function getLinesCount( _
             ByVal tgtCell As Range) As Long
  Dim i As Long
  Dim ret As Long
  ret = 1
  Dim cnt As Long
  cnt = 0
  Dim tgtStr As String
  With tgtCell
    tgtStr = .Value
    For i = 1 To Len(tgtStr)
      cnt = cnt + 1
      '改行文字にぶつかったらcntをリセットして行数をイン'
      'クリメント'
      If Mid(tgtStr, i, 1) = vbLf Then
        cnt = 0
        ret = ret + 1
        GoTo Continue
      End If
      'cntが1行あたり文字数に達したらcntをリセットして'
      '行数をインクリメント'
      If cnt Mod chrCntPerLine = 0 Then
        cnt = 0
        ret = ret + 1
      End If
Continue:
    Next
  End With
    getLinesCount = ret
End Function

行高を調整することに特化したモジュールを作った。

使ってみる

f:id:akashi_keirin:20200605182015g:plain

こんなふうにして行高を調整しても、画面上ではきれいにととのっているが、PDF化(印刷)してみると、

f:id:akashi_keirin:20200605182004j:plain

この体たらく。とほほ。

それが!

上記メソッドを用いて処理すると、

f:id:akashi_keirin:20200605182028g:plain

こうなって、PDF化(印刷)してみると、

f:id:akashi_keirin:20200605182010j:plain

バッチリ!

おわりに

だいぶまえにちゅん氏(id:Kotori-ChunChun)もやっていたような気がするので、勉強しに行きます。

表の中でのセルの位置を特定する(Word)

表の中でのセルの位置を特定する(Word)

Excelの表に比べて、Wordの表は勝手に改竄されることが今まで少なかったので、完全に油断していた。

Wordで集めた大量のドキュメント。ファイル名の付け方がバラバラなので、整理が大変。そこで、ドキュメント内に記入されている情報を元に、ファイル名をリネームすることにしたのです。たとえば、[会員番号] - [名前].docxみたいに。

あくまでも急場しのぎのマクロだし、そもそもWordの表に勝手に行や列を挿入するやつもまれだったので、「会員番号」とか「名前」を取得する表のインデックスとか、行番号、列番号なんて決め打ちで十分と思っていた。

しかし、現れやがったんですよ。強者が。

勝手に名前記入欄をすぐ下の表に接着するやつ

とか、

勝手に新しい表を挿入するやつ

なんかが・゜・(ノД`)・゜・。

しかも、一人や二人やない。ちょいちょい処理が止まる……。

とりあえず、その場は応急処置で乗り切ったが、この際なので一般化できるようにWordのTableオブジェクトについて勉強しておくことにした。

とりあえずキーワードを含むセルを返すFunctionを作る

今回の場合だと、まずは、たとえば、「会員番号」という文字列のあるセルを特定したい。

考え方

で、次のように考えた。

  • ドキュメント内のTableオブジェクトを全て巡回
  • Tableオブジェクト内のCellオブジェクトを総当たり
  • CellオブジェクトのRange.Textプロパティがキーワードを含んでいたら、そのCellオブジェクトを返す

ひとまずこんな感じ。

コード

ドキュメント内の全ての表のセルを巡回して、キーワードがヒットしたらそのセルを返すFunction。

リスト1
Public Function getCell( _
            ByVal KeyWord As String, _
   Optional ByVal tgtDoc As Document) As Cell
  Dim ret As Cell
  Set ret = Nothing
  '引数tgtDocが省略されていたらActiveDocumentをセット'
  If tgtDoc Is Nothing Then
    Set tgtDoc = ActiveDocument
  End If
  '全Tableを巡回'
  Dim tbl As Table
  For Each tbl In tgtDoc.Tables
    Set ret = getFoundCell(tbl, KeyWord)
    If Not ret Is Nothing Then Exit For
  Next
  Set getCell = ret
End Function
'Table内の全セルを巡回。キーワード見つけ次第return'
Private Function getFoundCell( _
             ByVal tgtTable As Table, _
             ByVal KeyWord As String) As Cell
  Dim ret As Cell
  Dim r As Long
  Dim c As Long
  Dim tmp As String
  For r = 1 To tgtTable.Rows.Count
    For c = 1 To tgtTable.Columns.Count
      'Cellオブジェクトを取得'
      Set ret = tgtTable.Cell(r, c)
      'セル内の文字列を取得'
      tmp = ret.Range.Text
      '右端のBELと改行コードを除去'
      tmp = Left(tmp, Len(tmp) - 2)
      'キーワードを含んでいたらreturn'
      If InStr(1, tmp, KeyWord) > 0 Then
        GoTo Finalizer
      End If
    Next
  Next
  Set ret = Nothing
Finalizer:
  Set getFoundCell = ret
End Function

とりあえずこんな感じ。本当なら、キーワードとセル内文字列の比較について、完全一致とか前方一致とかが選べるようにしたいけれど、ひとまず後回し。

使ってみる

f:id:akashi_keirin:20200602081307j:plain

このようなドキュメント(笑)を用意して、次のコードで使ってみる。

スト2
Private Sub test01()
  Dim tgtCell As Cell
  Set tgtCell = getCell("会員番号")
  Debug.Print tgtCell.RowIndex
  Debug.Print tgtCell.ColumnIndex
End Sub

こいつを実行すると、イミディエイト・ウィンドウに、

f:id:akashi_keirin:20200602081310j:plain

このように表示された。

うむ。バッチリである。

ついでにオフセットしたセルを取得するFunctionを作る

CellオブジェクトのParentプロパティを参照すれば、

f:id:akashi_keirin:20200602081313j:plain

この画像でおわかりのように、親のTableオブジェクトを取得することができる。

Cellオブジェクトからは、表の中での行番号、列番号を返すRowIndexColumnIndexプロパティがある。

……ということは、ExcelOffsetプロパティみたいなことができるはずだ。

よーし。作っちゃえ!

考え方

次のような仕様にすれば良い。

  • Cellオブジェクトと、行・列それぞれのオフセットサイズを受け取る
  • CellオブジェクトのParentプロパティを参照してTableオブジェクトを取得する
  • 行・列のオフセットサイズを元に、取得したいCellオブジェクトの表内での位置を求める
  • [Table].Cellメソッドで、取得したいCellオブジェクトを取得する

こんな感じ。

コード

上記のような考え方でコーディングした。

リスト3
Public Function getOffsetCell( _
            ByVal tgtCell As Cell, _
            ByVal RowOffset As Long, _
            ByVal ColumnOffset As Long) As Cell
  Dim ret As Cell
  Set ret = Nothing
  Dim currTable As Table
  Set currTable = tgtCell.Parent
  Dim r As Long
  r = tgtCell.RowIndex + RowOffset
  'rの値がおかしくなったらNothingを返す'
  If r < 1 Then GoTo Finalizer
  If r > currTable.Rows.Count Then GoTo Finalizer
  Dim c As Long
  c = tgtCell.ColumnIndex + ColumnOffset
  'cの値がおかしくなったらNothingを返す'
  If c < 1 Then GoTo Finalizer
  If c > currTable.Columns.Count Then GoTo Finalizer
  'オフセットしたセルを返す'
  Set ret = currTable.Cell(r, c)
Finalizer:
  Set getOffsetCell = ret
End Function

うむ。これで良い。

使ってみる

このドキュメント(笑)から、会員番号を取得して見せよう。

リスト4
Private Sub test02()
  Dim tgtCell As Cell
  Set tgtCell = getOffsetCell(getCell("会員番号"), 0, 1)
  Debug.Print tgtCell.Range.Text
End Sub

行オフセットサイズを0、列オフセットサイズを1にしているので、一つ右のセル、すなわち会員番号を取得できるはずだ。

こいつを実行すると、イミディエイト・ウィンドウは、

f:id:akashi_keirin:20200602081316j:plain

うむ。

さらに、イミディエイト・ウィンドウに

?getOffsetCell(getCell("名前"), 0, 1).Range.Text

と入力して[Enter]を押すと、

f:id:akashi_keirin:20200602081602j:plain

うむ。完璧である!!!!!!!!

おわりに

アクロバチック入力に対抗するのはなかなか大変である……orz

参照元に参照先の通し行番号を書き込む(1)

参照元に参照先の通し行番号を書き込む(1)

Wordの本文中で、参照箇所を明示したいときがある。段落番号とか見出しだったら、「相互参照」機能を使って文中に挿入できて、変更にも追随してくれるから良いのだが、通し行番号だけは、どうにもやり方がわからなかった。(もし「標準機能にあるで!」というのがあれば教えろ教えてください。)

行番号の参照などというものは、常に揺れ動くものなので、手動で管理するのは死ぬほどめんどくさいし、絶対に修正漏れが起こる。そこで、「ブックマーク」機能を使って解消することを考えた。

基本的には前回

akashi-keirin.hatenablog.com

までの続きです。

Bookmarkオブジェクトを使う

考え方

「ブックマーク」という機能を使えば、文書中の任意の場所に名前を付けることができる。VBAでは、Bookmarkオブジェクトを操作することによって、「ブックマーク」機能を使うことができる。

そこで、次のように考えた。

  • 参照先の箇所にブックマークを設定する
  • 参照元の「○行目」の行番号の部分(「○」の部分。)にブックマークを設定する
  • 前回作成したFunctionを用いて、参照先の通し行番号を取得する
  • 取得した行番号を文字列型に変換して「○」の部分に上書きする

こんな感じ。

ブックマークの設定

とりあえず、今回は手動で設定する。

まずは参照先。

f:id:akashi_keirin:20200601080004j:plain

このように、64行目の先頭に「参照先01」というブックマークを設定。

次に参照元

f:id:akashi_keirin:20200601080008j:plain

このように、「○行目」の「○」の部分に「参照元01」というブックマークを設定。

以上。

ブックマークした箇所(Rangeオブジェクト)の取得

まず、上記で設定したブックマークについて、Bookmarkオブジェクトを取得する方法。

これは、まずDocumentオブジェクトのBookmarksプロパティを参照してBookmarksコレクションを取得する。

んで、あとはItemメソッドのインデックスに取得したいブックマークの名前を指定すれば良い。

Itemは省略できるので、実際の書き方は

Document.Bookmarks("[ブックマーク名]")

になる。

Bookmarkオブジェクトが取得できれば、あとはそのRangeプロパティを参照すれば、ブックマークした箇所のRangeオブジェクトが取得できる。実に簡単。

参照元の文字を行番号に置き換える

参照元の「○」の部分をRangeオブジェクトとして取得しているのだから、あとはそのTextプロパティを書き換えたら良い。

楽勝!

コード

参照元に参照先の通し番号を挿入するコードは次の通り。

処理の中で、前回作成したgetLineNumberメソッドを呼び出しているので、そのコード(標準モジュールLineNumUtilに記載。)も再掲する。

リスト1 標準モジュール ModuleMain
Private Sub test00()
  Dim Doc As Document
  Set Doc = Application.ActiveDocument
  '参照元のブックマークオブジェクトを取得'
  Dim bm As Bookmark
  Set bm = Doc.Bookmarks("参照元01")
  '参照先ブックマークの通し行位置を取得'
  Dim lineNum As Long
  lineNum = LineNumUtil.getLineNumber(Doc.Bookmarks("参照先01").Range)
  '参照元のテキストを書き換える'
  bm.Range.Text = CStr(lineNum)
End Sub
スト2 標準モジュール LineNumUtil
Public Function getLineNumber( _
            ByVal tgtRange As Range) As Long
  Dim ret As Long
  'tgtRangeのあるページ番号を取得'
  Dim currPage As Long
  currPage = tgtRange.Information(wdActiveEndPageNumber)
  'tgtRangeのあるページ内での行番号を取得'
  Dim currLine As Long
  currLine = tgtRange.Information(wdFirstCharacterLineNumber)
  'tgtRangeが1ページ目にあるときは、その行番号を返す'
  If currPage = 1 Then
    ret = currLine
    GoTo Finalizer:
  End If
  '2ページ以上ある時は、手前のページまでの累計を足さなければいけない'
  Dim Doc As Document
  Set Doc = tgtRange.Parent
  'カーソル位置を記録'
  Dim orgRange As Range
  Set orgRange = Selection.Range
  '文書の先頭にカーソルを置く'
  Call Doc.Range(0, 0).Select
  '1ページ目の最終位置を取得'
  Dim pageEnd As Long
  '1ページ目の最終位置を選択'
  Dim i As Long
  For i = 1 To currPage - 1
    pageEnd = Doc.Bookmarks("\Page").End
    Call Doc.Range(pageEnd - 1, pageEnd - 1).Select
    ret = ret + Selection.Range.Information(wdFirstCharacterLineNumber)
    '次のページの先頭へ'
    Call Selection.MoveRight(wdCharacter, 1, wdMove)
  Next
  ret = ret + currLine
  'カーソル位置を戻す'
  Call orgRange.Select
Finalizer:
  getLineNumber = ret
End Function

例によって細かくコメントを入れたので、説明は省略。

うむ。これで盤石のはずだ!

使ってみる

リスト1を実行すると、

f:id:akashi_keirin:20200601080011j:plain

ウホッ! 完璧!

こんどは、

f:id:akashi_keirin:20200601080014j:plain

こんなふうにテキトーに参照先の位置をズレータにしておいて、再度実行!

f:id:akashi_keirin:20200601080017j:plain

な・・・・なんだってーーー!?

キ、キバヤシ……。これは一体どういうことなんだよ……。

あふれる涙を抑えながら「ブックマーク」を調べると、

f:id:akashi_keirin:20200601080020j:plain

なんと、テキストを書き換えたブックマーク(参照元01)が消えとる……orz

おわりに

どうも間違えてロンしてしまったか、フリテンだったようだ。

もう一工夫必要だということだ。

WordVBAはおれを甘やかしてくれぬ……。

で、今回の教訓。

BookmarkオブジェクトのRange.Textを書き換えるとBookmarkオブジェクトは消滅する。

覚えておこう。