ブック内で使用している関数の数をカウントするマクロ(Excel)

ブック内で使用している関数の数をカウントするマクロ(Excel

f:id:akashi_keirin:20210220222728j:plain

久しぶりのExcelネタだ。

とりあえずコードをぶちまける

f:id:akashi_keirin:20210220222511j:plain

現在(?)、Excelには、488個の関数があるらしい。

その488の関数名をコピッペしたこんなシートを用意して、

f:id:akashi_keirin:20210220222514j:plain

その関数名リストの部分に「FUNCTIONS_LIST」と名前を付けた。

これだけ準備をしておいて、このシートのモジュール(「Sh01Main」と名付けてある。)に、次のコードを書いた。

先に言っておく。長いぜ。

リスト1 シートモジュールSh01Main
Option Explicit

Private Const FUNCTIONS_LIST As String = "FUNCTIONS_LIST"

Private m_FunctionsArr As Variant '関数名リスト用'
Private m_CountArr() As Long      '関数使用数格納用'
Private m_FormulaArr As Variant   '各セルの数式格納用'
Private m_OpeArr() As String      '関数名のアタマの記号格納用'
Private m_CountArea As Range      '使用数書き込み先セル格納用'

Private Sub countFunctionsEntry(ByVal TgtBook As Workbook)
  '処理に使う変数等の準備'
  '関数名のアタマに付く可能性のある記号たち(網羅できている?)'
  Const PRE_OPERATORS As String = "= ( + - * / & < > ^ ,"
  m_OpeArr = Split(PRE_OPERATORS)
  m_FunctionsArr = Me.Range(FUNCTIONS_LIST).Value
  ReDim m_CountArr(1 To UBound(m_FunctionsArr, 1) + 1, 1 To 1)
  Set m_CountArea = Me.Range(FUNCTIONS_LIST).Offset(0, 1)
  Call m_CountArea.ClearContents
  'ブック内のワークシートごとにメソッド呼び出し'
  Dim tgtSh As Worksheet
  For Each tgtSh In TgtBook.Worksheets
    Call countSheetsFunctions(tgtSh)
  Next
  '最後に関数の使用数を書き込む'
  m_CountArea.Value = m_CountArr
End Sub

Private Sub countSheetsFunctions(ByVal TgtSheet As Worksheet)
'///シート内各セルの数式を取得'
  'UsedRangeがなかったら処理しなくて良い'
  If TgtSheet.UsedRange.Count = 0 Then Exit Sub
  'UsedRangeが1セルだったら、別途2次元配列化する'
  If TgtSheet.UsedRange.Count = 1 Then
    ReDim m_FormulaArr(1, 1)
    m_FormulaArr(1, 1) = TgtSheet.UsedRange.Cells(1, 1).Formula
  '2セル以上あるときは、直接2次元配列化'
  Else
    m_FormulaArr = TgtSheet.UsedRange.Formula
  End If
  '数式がある限り、一つ一つ調べる'
  Dim i As Long
  Dim j As Long
  For i = LBound(m_FormulaArr, 1) To UBound(m_FormulaArr, 1)
    For j = LBound(m_FormulaArr, 2) To UBound(m_FormulaArr, 2)
      If m_FormulaArr(i, j) = "" Then GoTo Continue
      Call countFunctions(m_FormulaArr(i, j))
Continue:
    Next
  Next
End Sub

Private Sub countFunctions(ByVal TgtFormula As String)
'///関数名ごとに数式内に含まれているかどうか調べる'
  If Left(TgtFormula, 1) <> "=" Then Exit Sub
  Dim i As Long
  Dim funcName As String
  Dim n As Long
  Dim result As Long
  For i = LBound(m_FunctionsArr, 1) To UBound(m_FunctionsArr, 1)
    funcName = m_FunctionsArr(i, 1)
    '「関数名 + (」が含まれていなければ調べなくて良い'
    If InStr(1, TgtFormula, funcName & "(") = 0 Then GoTo Continue
    Call detectFunction(TgtFormula:=TgtFormula, _
                        TgtFuncName:=funcName, _
                        TgtIndex:=i)
Continue:
  Next
End Sub

Private Sub detectFunction(ByVal TgtFormula As String, _
                           ByVal TgtFuncName As String, _
                           ByVal TgtIndex As Long)
'///「先頭記号 + 関数名 + (」が見つかるごとにカウントアップ'
  Dim n As Long
  Dim result As Long
  Dim i As Long
  For i = LBound(m_OpeArr) To UBound(m_OpeArr)
    n = 1
    Do
      result = InStr(n, TgtFormula, m_OpeArr(i) & TgtFuncName & "(")
      If result > 0 Then
        '見つかったら関数使用数格納用配列の当該要素をカウントアップ'
        m_CountArr(TgtIndex, 1) = m_CountArr(TgtIndex, 1) + 1
        n = result + Len(TgtFuncName) + 2
        '次の検索開始位置(result + (関数名の長さ + 2)) の値から、'
        '残りの文字数を調べる。                                    '
        '「2」は、関数名の前の文字と関数名の後ろの「(」の字数      '
        '残りの文字数が、関数名 + 2 (検索対象文字列の文字数)より '
        'も少なかったら検索終了。'
        If Len(TgtFormula) - n + 1 < Len(TgtFuncName) + 2 Then Exit Do
      Else
        Exit Do
      End If
    Loop
  Next
End Sub

Private Sub entryPoint()
'///エントリポイント'
'   同一フォルダ内の test.xlsm にある関数名をカウントする'
  Dim tgtBk As Workbook
  Set tgtBk = Application.Workbooks.Open( _
                            ThisWorkbook.Path & "\" & "test.xlsm")  '"
  Call countFunctionsEntry(tgtBk)
  Call tgtBk.Close(False)
End Sub

ふう。長いなあ……。

とりあえずコードを晒したかっただけなので、説明は省略。

使ってみる

同じフォルダ内に、「test.xlsm」というファイル名の数式入りExcelブックを置いておいて、上記リスト1のentryPoint(一番下のプロシージャ)を実行すると……。

f:id:akashi_keirin:20210220222532j:plain

こうなる。メチャクチャ力技な処理の割には、結構速い。

使用回数順に並べ替えると、

f:id:akashi_keirin:20210220222535j:plain

実にわかりやすい。

おわりに

ただし、一定の条件を満たしていれば、数式として機能していない文字列をカウントしてしまうので、正確な数値が出るとは限らないこと、お断りしておきます。

関数のアタマにくっつく可能性のある記号類は、網羅できているんですかね?

割り当てたショートカットキーを忘れないようにする

割り当てたショートカットキーを忘れないようにする

f:id:akashi_keirin:20210219185103j:plain

これはタイトルに偽りありかも知れない。

よく使うマクロを使いやすくする

クイック アクセス ツール バーを使う

たとえば、前回

akashi-keirin.hatenablog.com

紹介した〝選択箇所に傍点を施すマクロ〟のような、〝ちょっと便利なマクロ〟は、サクッと気軽に使いたい。

そのための一つの方法が

クイック アクセス ツール バーに登録する

というものだろう。

これはかつて書いたことがあるので、

akashi-keirin.hatenablog.com

コチラをどうぞ。

これで、ワンクリックで機能を呼び出すことができる。

f:id:akashi_keirin:20210219185111g:plain

便利!

ショートカットキーを割り当てる

しかし、いちいちクイック アクセス ツール バーをクリックしに行くのがめんどくさい、ということもあるかもしれない。

そんなときは、ショートカットキーを割り当てたらよい。

やり方は、

tonari-it.com

コチラをどうぞ。

f:id:akashi_keirin:20210219185140g:plain

これはこれで実に快適。

ショートカットキー割り当ての問題点

しかし、困ったことが一つ。

どのショートカットキーを割り当てたか、忘れるのである。

これは困った。

〝ショートカットキーを忘れる〟問題への対応

そこで、ナイスなアイディアを思いついた。

忘れるなら、思い出させれば良いのである。

名付けて、

マリー・アントワネット作戦

である!

リスト1
Public Sub AddEmphasisMain()
  Static hasShown As Boolean
  Call AddEmphasisMark
  If Not hasShown Then
    Debug.Print "ショートカット キーは、[Ctrl]+[Alt]+[@]や。"
    hasShown = True
  End If
End Sub

Public Sub AddEmphasisMark( _
  Optional ByVal EmphasisMarkType As WdEmphasisMark = wdEmphasisMarkOverComma)
  Dim rng As Range
  Set rng = Selection.Range
  rng.EmphasisMark = EmphasisMarkType
End Sub

ショートカットキーを忘れたら、一度クイック アクセス ツール バーから実行し、イミディエイトを見れば良いのである!

f:id:akashi_keirin:20210219185108j:plain

そして、Static変数でイミディエイトへの出力の有無を切り替えているので、以後実行するごとにイミディエイトにメッセージがたまっていく、ということもない。

おわりに

まさに、天才的アイディアである!

(「羊頭狗肉」だと?! うるせえ、黙ってろ!)

傍点マクロをNormal.dotmに書く(Word)

傍点マクロをNormal.dotmに書く

f:id:akashi_keirin:20210217085235j:plain

傍点マクロをNormal.dotmに書く

前回

akashi-keirin.hatenablog.com

作成した傍点マクロ。私は文書作成時にやたらと傍点を使う(というよりは、私の尊敬する書き手が皆一様によく傍点を使うため、引用するときにやたら傍点を施す必要が生ずる)ので、傍点が気軽に打てるのは助かる。

そこで、傍点マクロをいろいろなドキュメントで使い回せるように、標準テンプレートであるNormal.dotmに置くことにする。

Normal.dotmに標準モジュールを置く

まず、プロジェクト エクスプローラー上で、「Normal」のところの「+」をクリックする。

f:id:akashi_keirin:20210217085240j:plain

次に、「Microsoft Word Object」のところの「+」をクリックする。

f:id:akashi_keirin:20210217085242j:plain

ThisDocument」のあたりで右クリックし、コンテキストメニューを「挿入」→「標準モジュール」の順にクリックする。

f:id:akashi_keirin:20210217085245j:plain

これで、めでたく標準モジュール「Module1」が生まれた。

f:id:akashi_keirin:20210217085248j:plain

モジュール名が気にくわなければ、プロパティウィンドウの「オブジェクト名」のところ

f:id:akashi_keirin:20210217085251j:plain

で名前を変更してやれば良い。

画像では「UsefulMacros」としている。

f:id:akashi_keirin:20210217085253j:plain

設置した標準モジュールにコードを書く

前回記事のリスト1リスト2を先ほど挿入した標準モジュールに書く。

リスト1(再掲)
Private Sub addEmphasisMark( _
  Optional ByVal EmphasisMarkType As WdEmphasisMark =  _
                                     wdEmphasisMarkOverComma)
  Dim rng As Range
  Set rng = Selection.Range
  rng.EmphasisMark = EmphasisMarkType
End Sub
スト2(再掲)
Public Sub AddEmphasisMarkMain()
  Call addEmphasisMark
End Sub

とりあえずこんだけ。

終わりに

これで、このマクロを仕込んだ端末で編集するたいていのWordドキュメントで傍点マクロを使用することが可能になる。(ですよね?)

選択箇所に傍点を施す(Word)

選択箇所に傍点を施す

f:id:akashi_keirin:20210216232214j:plain

選択箇所に傍点を施すマクロ

選択箇所に傍点を施すのはめんどくさい

選択箇所に傍点を施すのは実にめんどくさい。

f:id:akashi_keirin:20210216232035j:plain

仮に、リボンのタブが「ホーム」にある状態からでも、

f:id:akashi_keirin:20210216232032j:plain

対象範囲を選択し、

「フォント」グループの「ダイアログボックスランチャー」(みんな、こんな名前だって知ってた?)をクリックし、

f:id:akashi_keirin:20210216232038j:plain

「傍点」のところのドロップダウンをクリックし、

f:id:akashi_keirin:20210216232042j:plain

任意の傍点の種類をクリックし、

f:id:akashi_keirin:20210216232045j:plain

[OK]をクリックする

f:id:akashi_keirin:20210216232048j:plain

と、範囲を選択してからでも、実に4回ものクリックを重ねなければたどり着けない苦難の道のりなのである。

f:id:akashi_keirin:20210216232059j:plain

これはめんどくさい。

そう思ったら、マクロですよ!

選択箇所に傍点を施すマクロ

これは実に簡単。

傍点を施したい箇所のRangeオブジェクトを取得し、そのRangeオブジェクトのEmphasisMarkプロパティに望みの値を設定してやればよい。

EmphasisMarkプロパティの値の設定には、WdEmphasisMark列挙体の使用が可能。列挙体の各要素は次の通り。

f:id:akashi_keirin:20210216232110j:plain

  1. wdEmphasisMarkNone
  2. wdEmphasisMarkOverComma
  3. wdEmphasisMarkOverSolidCircle
  4. wdEmphasisMarkOverWhiteCircle
  5. wdEmphasisMarkUnderSolidCircle

まあ、名前を見たらだいたいどんなのか想像つくと思う。

日本語の文章で使うのはほぼ「wdEmphasisMarkOverComma」でしょう。

コードは次のような実に簡単なものになる。

リスト1
Private Sub addEmphasisMark( _
  Optional ByVal EmphasisMarkType As WdEmphasisMark =  _
                                     wdEmphasisMarkOverComma)
  Dim rng As Range
  Set rng = Selection.Range
  rng.EmphasisMark = EmphasisMarkType
End Sub

引数としてWdEmphasisMark列挙体を受け取って、その傍点を選択範囲に施す、というだけのもの。

先にも述べたとおり、日本語の文書では通常「、」の形の傍点を使うので、Optionalにした上でデフォルト値をwdEmphasisMarkOverCommaにしている。

使ってみる

次のコードで実行。

スト2
Public Sub AddEmphasisMarkMain()
  Call addEmphasisMark
End Sub

これで良い。

対象の箇所を選択して、リスト2を実行する。

f:id:akashi_keirin:20210216232113g:plain

ほれ、バッチリ。

おわりに

なんで今までこういうことをしてこなかったのだろう。

段落単位で置換できる(Word)

段落単位で置換できる

Wordで、特定の範囲だけ置換したかった。

f:id:akashi_keirin:20210210084737j:plain

目次

標準機能による置換

普通、置換はこうする。

f:id:akashi_keirin:20210210084543j:plain

画像中に示した、「《 》」でくくられた箇所を置換したいとき、[Ctrl] + [ H ]で置換ダイアログを呼び出して、

f:id:akashi_keirin:20210210084546j:plain

このようにすればよい。

しかし、これだと当たり前のことながら、文書全体の当該箇所が根こそぎ置換されてしまう。

もちろん、必要な範囲のみ選択した状態で実行すれば良いが、それは単に〝手動〟なのであって、あまり有効な解決策とは言えない。

Find.Executeメソッドによる置換

たとえば、次のリスト1を実行するとどうか。

リスト1 標準モジュール
Private Sub test01()
  Call Selection.Find.Execute(FindText:="《*》", _
                              ReplaceWith:="", _
                              Replace:=wdReplaceAll, _
                              MatchWildcards:=True)
End Sub

こいつを実行するとどうなるか。

カーソルのある場所以降の部分のみ置換されるのである。

これは実に便利な仕様。

しかし、これは〝どこから〟しか指定できないことを意味する。

段落単位でFind.Executeメソッドを使う

Wordでは、段落単位で文書の断片を取得することができる。

[Document].Paragraphsコレクションのインデックスを指定すれば良いのである。

たとえば、18番目~21番目の段落の部分のみ置換を実行したければ、次のようなコードを書けば良い。

スト2 標準モジュール
Private Sub test02()
  Dim Doc As Document
  Set Doc = ActiveDocument
  Dim i As Long
  For i = 18 To 21
    With Doc.Paragraphs(i)
      Call .Range.Find.Execute( _
                         FindText:="《*》", _
                         ReplaceWith:="", _
                         Replace:=wdReplaceAll, _
                         MatchWildcards:=True)
    End With
  Next
End Sub

見ての通り、1821の各段落に順に[Range].Find.Executeメソッドを実行して置換している。

f:id:akashi_keirin:20210210084550j:plain

結果はこの通り。

見事に狙った箇所のみ置換することに成功している。

おわりに

これで、置換を施したい対象箇所の始めと終わりに、当該文書内では出てこないような文字列(「@@@」とか。)を目印として置いておき、その段落を取得するようにすれば、文書内の狙った範囲の箇所にのみ置換を実行することができる。

段落番号を取得するやつは、

akashi-keirin.hatenablog.com

このときに作成済み。

Wordの表の中の文字列

f:id:akashi_keirin:20210207182233j:plain

Wordの表の中の文字列

けったいな現象が起こったので報告。

表の中の文字列

Wordドキュメント上に、次のような表を作成する。

f:id:akashi_keirin:20210207181729j:plain

で、次のコードで表の左上端セルの文字列を取り出してみる。

リスト1 標準モジュール
Private Sub test()
  Dim tbl As Table
  Set tbl = ActiveDocument.Tables(1)
  Dim rng As Range
  Set rng = tbl.Cell(1, 1).Range  '……(1)'
  Debug.Print rng.Text            '……(2)'
  Debug.Print Len(rng.Text)
End Sub

(1)の

Set rng = tbl.Cell(1, 1).Range

で、表の中の左上端セルを指し示すRangeオブジェクトを変数rngに突っ込み、(2)からの2行

Debug.Print rng.Text
Debug.Print Len(rng.Text)

でそのRangeオブジェクトが持っている文字列を出力するとともに、その文字列の文字数を出力する。

コイツを実行してやると、

f:id:akashi_keirin:20210207181732j:plain

となる。

セルの中の文字列は「アホ」と改段落マークなので、文字数は3と思いきや、4である。

イミディエイトの結果を見ても、「アホ」の他に、改段落と何かわけのわからんものが付着しているのが何となく分かる。

ケツに付着している文字は何か

このケツに付着している文字が何なのかを調べる。

今度は、次のコードでやってみる。

スト2 標準モジュール
Private Sub test08()
  Dim tbl As Table
  Set tbl = ActiveDocument.Tables(1)
  Dim rng As Range
  Set rng = tbl.Cell(1, 1).Range
  Debug.Print rng.Text
  Debug.Print Len(rng.Text)
  Debug.Print Asc(Right(rng.Text, 1))  '……(3)'
End Sub

先のリスト1に(3)の

Debug.Print Asc(Right(rng.Text, 1))

を付け加えただけ。

rng.Textの一番ケツの文字の文字コード番号を出力する。

こいつを実行すると、

f:id:akashi_keirin:20210207181736j:plain

こうなる。

ケツにひっついているのは、文字コード7」のやつ、つまり、Chr(7)なのである。

Chr(7)とは?

コチラのサイトによると、Chr(7)とは、

f:id:akashi_keirin:20210207181739j:plain

BELというやつである。

なんじゃそら。〔

とにかく、Wordの表のセル内の文字列のケツには、「ベル文字」というやつがひっついているらしい。

ベル文字を除去するとどうなるか

では、この「ベル文字」とやらを除去するとどうなるのか。

次のコードで実験。

リスト3 標準モジュール
Private Sub test08()
  Dim tbl As Table
  Set tbl = ActiveDocument.Tables(1)
  Dim rng As Range
  Set rng = tbl.Cell(1, 1).Range
  rng.Text = Replace(rng.Text, Chr(7), "")  '……(4)'
End Sub

(4)の

rng.Text = Replace(rng.Text, Chr(7), "")

で、Replace関数を用いて「ベル文字」を除去した文字列をrng.Textにセットしてやるのだ。

ふふふ。「ベル文字」とやら、消え失せい!!!!!!!!

f:id:akashi_keirin:20210207181743j:plain

な…なんだってー!!

わけわからん……。

セル内の文字列はどうなっとるのか

次のコードで調べてみた。

リスト4 標準モジュール
Private Sub test09()
  Dim tbl As Table
  Set tbl = ActiveDocument.Tables(1)
  Dim rng As Range
  Set rng = tbl.Cell(1, 1).Range
  Dim tmp As String
  tmp = rng.Text
  Dim i As Long
  For i = 1 To Len(tmp)
    Debug.Print Asc(Mid(tmp, i, 1))
  Next
End Sub

セル内の文字列を1文字づつ切り出して、Asc関数でコード番号を出力してみる。

f:id:akashi_keirin:20210207181745j:plain

なんと、Chr(7)ポアしたはずなのに、復活しているどころか「Chr(13) & Chr(7)」に置き換わってしまっておるではないか……。

おわりに

謎は深まるばかりである……。

「青空文庫」をWordVBAで攻略する(2)

ルビを振るべき親文字の箇所を取得する

前回

akashi-keirin.hatenablog.com

紹介したのは、「青空文庫」からダウンロードしたテキストファイルから、ルビ情報(「《 》」で括られた文字列)を削除する、という対応だった。

しかし、いくら読みやすさのためといえども、ルビ情報全削除はあんまりである。

当然、次に目指すべきは、

ちゃんとルビを振ろうぜ

ということになる。

目次

こんなことをします

ルビの親文字に相当する部分をRangeオブジェクトとして取得するために必要なFunctionを作る。

通常であれば、これは人間にしか(完全には)なし得ない作業だが、幸い「青空文庫」では明確なルールに基づいてテキストデータを作ってくれているので、なんとかなる。

詳細は後述。

とにかく、たとえば、

f:id:akashi_keirin:20210131183928j:plain

この画像の中でいえば、

左の手で小次郎の鼻息《びそく》をそっと触れてみた。

の中から、

f:id:akashi_keirin:20210131183932j:plain

このように、親文字となるべき「鼻息」の部分をRangeオブジェクトとして取得するのである。

考え方

先述の通り、「青空文庫」では、次のようなルールでルビ情報をテキストデータ上で表現している。

  • 親文字の直後に「《 》」で括ってルビを示す
    【例】:小次郎の鼻息《びそく》→「鼻息」が親文字
  • ルビを振らない漢字と隣接しているときは、区切りの部分に「|」(全角バーティカルバー)が入っている
    【例】:柳生|石舟斎《せきしゅうさい》→「石舟斎」が親文字

実に明解。

つまり、「」の手前から遡り、非漢字にぶつかるか、「|」にぶつかるかしたら、その直後の位置までが親文字ということだ。

処理の手順は次の通り。すなわち、

  1. 《 》」で括られた部分のRangeオブジェクトを取得
  2. 取得したRangeオブジェクトを一旦開始方向に向けて潰し、その位置(*1)を取得する
  3. そこから1文字づつ遡って、漢字かどうか、または「|」かどうかを調べる
  4. 非漢字または「|」にぶつかったら、その直後の位置を取得する(*2)
  5. (*1)、(*2)で取得した位置を元にRangeオブジェクトを作成する

このような手順である。

ルビの親文字の箇所を取得する

指定した文字の位置を取得する

これは、前回も使用したgetNextPositionメソッドを使う。

コードを再掲する。

リスト1 標準モジュールFormatStrings
Private Function getNextPosition( _
             ByVal FindText As String) As Long
  Dim ret As Long
  ret = -1
  With Selection.Find
    .Text = FindText
    .Replacement.Text = ""
    .Wrap = wdFindStop
    .Format = False
    .Highlight = False
    .MatchCase = False
    .MatchFuzzy = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
  End With
  Call Selection.Find.Execute
  If Not Selection.Find.Found Then GoTo ReturnValue
  ret = Selection.Range.Start
  Call Selection.Collapse(wdCollapseEnd)
ReturnValue:
  getNextPosition = ret
End Function

漢字かどうかを判定するFunction

これまた、ずいぶん前に書いたコードを再利用する。

スト2 標準モジュールFormatStrings
Private Function isKanji( _
             ByVal tgtChar As String) As Boolean
  isKanji = False
  Dim char As String * 1
  char = tgtChar
  If CInt(Asc(tgtChar)) > 0 Then Exit Function
  If CInt(Asc(char)) < CInt(&H889F) Then Exit Function
  isKanji = True
End Function

Privateメソッドで、1文字だけ渡して漢字かどうかを判定するだけの用途に使うので、ややこしい引数チェック等はなし。

親文字の箇所を取得するFunction

ここまでで準備はオッケー。後はコーディングあるのみ!

リスト3 標準モジュールFormatStrings
Private Function getRubiedCharPosition( _
             ByVal BasePos As Long, _
    Optional ByVal Delimiter As String = "|") As Long  '……(1)'
  Dim ret As Long  '……(2)'
  ret = 0
  Dim tgtDoc As Document
  Set tgtDoc = ActiveDocument
  Call tgtDoc.Range(BasePos, BasePos).Select  '……(3)'
  
  Dim tmp As String    '……(4)'
  Do
    tmp = tgtDoc.Range(BasePos - 1, BasePos).Text  '……(5)'
    If Not isKanji(tmp) Or tmp = Delimiter Then  '……(6)'
      ret = BasePos    '……(7)'
      Exit Do
    Else
      BasePos = BasePos - 1    '……(8)'
      If BasePos < 0 Then Exit Do
    End If
  Loop
  getRubiedCharPosition = ret
End Function

まず、(1)の

Private Function getRubiedCharPosition( _
             ByVal BasePos As Long, _
    Optional ByVal Delimiter As String = "|") As Long

で引数と返り値の設定。

引数BasePosは探索の開始位置。「青空文庫」でいえば、「」の直前の位置ということになる。

引数Delimiterは、親文字開始の目印となる文字。

青空文庫」の場合、「」という非漢字文字が区切りの役割を果たしているので、デフォルト値を「」にする意味はない。

とにかく、「」の直前の位置から遡り、非漢字文字にぶつかったらその直後の位置を整数値で返すので、返り値はLong型。

(2)の

Dim ret As Long
ret = 0

で返り値用変数と初期値を設定。

文書の先頭から親文字が始まる可能性があるので、初期値は0

先頭まで行っても非漢字文字にぶつからないということは、(「青空文庫」のボランティアスタッフがミスったのでない限り、)文書の先頭が親文字の開始位置だということだ。

探索を繰り返して、非漢字文字にぶつからないまま文書先頭に至ったときには「0」を返すようにするために、こうしておく。

(3)の

Call tgtDoc.Range(BasePos, BasePos).Select

で、探索開始位置にカーソルをセット。

(4)からの11行

Dim tmp As String
  Do
  tmp = tgtDoc.Range(BasePos - 1, BasePos).Text  '……(5)'
  If Not isKanji(tmp) Or tmp = Delimiter Then  '……(6)'
    ret = BasePos    '……(7)'
    Exit Do
  Else
    BasePos = BasePos - 1    '……(8)'
    If BasePos < 0 Then Exit Do
  End If
Loop

が探索過程。

まず、(5)の

tmp = tgtDoc.Range(BasePos - 1, BasePos).Text

で、先頭方向に1文字分の文字を取得。

(6)の

If Not isKanji(tmp) Or tmp = Delimiter Then

で、その文字が〝非漢字または区切り文字〟であるかどうかをを判定し、Trueならば、(7)の

ret = BasePos
Exit Do

で位置を返す。

非漢字文字にぶつかった時点で、BasePosの値は非漢字文字の直後、すなわち親文字の開始位置を表すので、これでよい。

(6)の判定結果がFalseだったら、(8)の

BasePos = BasePos - 1
If BasePos < 0 Then Exit Do

BasePosの値を1減らす。

また、1減らした段階でBasePosの値が負の数になっていたら、それ以上探索しても無駄なのでループを抜ける。(0が返ることになる。)

ルビの親文字の箇所を取得する

ここまでで準備はできた。

まさに、「時は来た、それだけだ!」状態である。

上掲getNextPositionで、「」の位置を取得すれば、それが〝ルビの親文字の箇所〟の終端となり、getRubiedCharPositionで、文書前方の直近の非漢字文字の直後の位置を取得すれば、それが〝ルビの親文字の箇所〟の始端となるのである!

つまり、たとえば、

f:id:akashi_keirin:20210131183935j:plain

このようにカーソルを置いて、次のコードを実行すれば、親文字の部分が選択されることになる。

リスト4 標準モジュール
Private Sub test00()
  Dim rng As Range
  Dim startPos As Long
  Dim endPos As Long
  endPos = getNextPosition("《")
  startPos = getRubiedCharPosition(endPos)
  Set rng = ActiveDocument.Range(startPos, endPos)
  Call rng.Select
End Sub

f:id:akashi_keirin:20210131183938j:plain

ほれ、この通り。

f:id:akashi_keirin:20210131183941j:plain

この状態で実行したら、

f:id:akashi_keirin:20210131183944j:plain

当然こうなる。

おわりに

あとは、親文字にルビを振り、「《 》」で括られた部分を削除するだけ。

ここまで来たら、あとは楽勝でしょう。