【VBA】ExcelからWord操作：文字列を検索して結果出力したい

Question

実現したいこと

エクセルの＜検索文字列＞シートのA列に列挙されている検索文字列群（A1からA2、A3、、、に検索したい文字が入力されています）がwordファイルの文章中に使われているかそれぞれ検索し、出現ページ・行を＜結果＞シートに出力したい。

エラー・回避したいこと

wordファイルの文章中の検索対象文字列にルビがふられていた場合、無限ループになってしまう。
例）「回避」が検索文字列で、wordファイルの文章のどこかで「回避」という文字が使われており、さらに「かいひ」とwordのルビ機能を使ってルビがふられていた場合に、無限ループになって固まってしまいます。
いろいろ調べてみましたが自分の力では回避できなかったのでこちらで質問させていただきます。

コード

maxRowは＜検索文字列＞シートの最終行番号が格納
iRowは＜結果＞シートの結果を書き出す開始行番号が格納

    For i = 1 To maxRow
        wd = ThisWorkbook.Worksheets("検索文字列").Range("A" & i + 1).Value
        With wdApp.Selection
            .Find.Text = wd
            .Find.Forward = True
            .Find.MatchWholeWord = True
            .Find.MatchCase = True
            .Find.Wrap = wdFindContinue
            Do While .Find.Execute
                p = .Range.Information(wdActiveEndPageNumber)
                l = .Range.Information(wdFirstCharacterLineNumber)
                With ThisWorkbook.Worksheets("結果")
                    .Range("A" & iRow) = p & "P、" & l & "行目"
                    .Range("B" & iRow) = wd
                End With
                iRow = iRow + 1
            Loop
        End With
    Next

環境

Excel 2016、Word 2016、VBA 7.1

Answer 1

質問時のコードに対し、２か所修正して解決できました。

①ページ番号および行番号を取得する際のRangeオブジェクトを変更
.Find.Executeしてヒットした際に、.Range.Information(略)が実行されると、ルビの場合には次に移らずハマって無限ループとなっていました。（ルビがふられている場合、カーソルを合わせると自動でルビの文字全体が選択される仕様が関係しているのかと思われますが詳細はよくわかりません。）
これを回避するため、Rangeオブジェクトではなく、そのままSelectionオブジェクトのInformationを取得するようにしました。
↓の部分を、

                p = .Range.Information(wdActiveEndPageNumber)
                l = .Range.Information(wdFirstCharacterLineNumber)

↓のように修正

                p = .Information(wdActiveEndPageNumber)
                l = .Information(wdFirstCharacterLineNumber)

②検索文字列が変わるごとにカーソルを文頭に移動させる
もともとのコードですと次の検索文字列に移った際に文章の途中から検索を開始して、結果が重複して出力される状態でした。そのため、次の文字列に移った場合は文頭から検索されるよう、カーソルを文頭に移動させるようにしました。
↓のコードを追加

            .Move Unit:=wdStory, Count:=-1 '文章の先頭にカーソルを移動

解決できたコードは以下のとおりです。

    For i = 1 To maxRow
        wd = ThisWorkbook.Worksheets("検索文字列").Range("A" & i + 1).Value
        With wdApp.Selection
            .Move Unit:=wdStory, Count:=-1 '文章の先頭にカーソルを移動
            .Find.Text = wd
            .Find.Forward = True
            .Find.MatchWholeWord = True
            .Find.MatchCase = True
            .Find.Wrap = wdFindContinue
            Do While .Find.Execute
                p = .Information(wdActiveEndPageNumber)
                l = .Information(wdFirstCharacterLineNumber)
                With ThisWorkbook.Worksheets("結果")
                    .Range("A" & iRow) = p & "P、" & l & "行目"
                    .Range("B" & iRow) = wd
                End With
                iRow = iRow + 1
            Loop
        End With
    Next

Comments

[ken3memo]

＞（ルビがふられている場合、カーソルを合わせると自動でルビの文字全体が選択される仕様が関係しているのかと思われますが詳細はよくわかりません。）

本筋の.Find.で無限ループになる原因がわかって、よかったてす。
私も、すっきりしました。

Answer 2

処理イメージは下記のような感じで良いですか？
https://youtu.be/dSlL0aNsI28?t=76
↑実行結果の動画です、確認してみてください

.Findでループしてしまう理由が私もわからなかったので、
ActiveDocument.Paragraphs から 泥臭く探ってみました
※maxRow = 3 '最終行を代入してね テストで3個固定なので、修正してね

Sub test20220121WORD検索テスト2()

    Dim wdApp As Word.Application
    Set wdApp = GetObject(, "Word.Application")

    If wdApp Is Nothing Then
        MsgBox "テスト用のWORD文章を開いてから、再テストしてね"
        Exit Sub
    End If

    Dim i As Integer
    Dim iRow As Integer
    
    Dim maxRow As Integer
    Dim wd As String
    Dim p As Integer, l As Integer   'ページ、行
    
    Dim n As Integer '段落のカウンターで使用
    Dim str段落文字列 As String
    Dim n先頭位置 As Integer
    
    maxRow = 3 '最終行を代入してね テストで3個固定なので、修正してね
    iRow = 1   '結果一行目から、あっ、実行時に結果のシート消さなきゃ↓・・・
    ThisWorkbook.Worksheets("結果").Range("A:A").Clear  'A列をクリア

    For i = 1 To maxRow
        wd = ThisWorkbook.Worksheets("検索文字列").Range("A" & i + 1).Value  '検索文字列
        
        'アクティブ文書の段落を頭からなめる ActiveDocument.Paragraphs
        For n = 1 To wdApp.ActiveDocument.Paragraphs.Count
            str段落文字列 = wdApp.ActiveDocument.Paragraphs(n).Range.Text
            '単純にInstrで探してみた
            n先頭位置 = InStr(1, str段落文字列, wd) '初回は一文字目から探す
            While n先頭位置 <> 0 '検索位置が見つかっている間 0以外の時ループ
                If n先頭位置 > 0 Then '↑で文字が見つかったら、
                    wdApp.ActiveDocument.Paragraphs(n).Range.Select   '見つけたので段落選択する
                    '↑段落全体が選択されているので、↓選択範囲、start位置を移動
                    wdApp.Selection.MoveStart Unit:=wdCharacter, Count:=n先頭位置 - 1
                    '結果をExcelへ書く、
                    p = wdApp.Selection.Range.Information(wdActiveEndPageNumber)
                    l = wdApp.Selection.Range.Information(wdFirstCharacterLineNumber)
                    With ThisWorkbook.Worksheets("結果")
                        .Range("A" & iRow) = p & "P、" & l & "行目"
                        .Range("B" & iRow) = wd
                    End With
                    iRow = iRow + 1
                End If
                            
                '次の位置(見つけた位置+検索文字数)から検索文字を探す
                n先頭位置 = InStr(n先頭位置 + Len(wd), str段落文字列, wd) '同じ段落に検索文字があるかもしれないので
            
            Wend
            
        Next n
        
    Next

    MsgBox "処理終了、結果を確認してください"

End Sub

2022/01/24 ルビに対応したコードに修正

'ルビを振った文字列を検索する※ルビが別に管理されていることに気が付く・・・
Sub test20220124WORD検索テスト3ルビを探る()

    Dim wdApp As Word.Application
    Set wdApp = GetObject(, "Word.Application")

    If wdApp Is Nothing Then
        MsgBox "テスト用のWORD文章を開いてから、再テストしてね"
        Exit Sub
    End If

    Dim i As Integer
    Dim iRow As Integer
    
    Dim maxRow As Integer
    Dim wd As String
    Dim p As Integer, l As Integer   'ページ、行
    
    Dim n As Integer '段落のカウンターで使用
    Dim str段落文字列 As String
    Dim n先頭位置 As Integer
    
    Dim strルビ情報 As String   'ActiveDocument.Fields(n) なので、ルビ以外もあるけどね 2022/01/24追加
    
    maxRow = 3 '最終行を代入してね テストで3個固定なので、修正してね
    iRow = 1   '結果一行目から、あっ、実行時に結果のシート消さなきゃ↓・・・
    ThisWorkbook.Worksheets("結果").Range("A:B").Clear  'A,B列をクリア

    For i = 1 To maxRow
        wd = ThisWorkbook.Worksheets("検索文字列").Range("A" & i + 1).Value  '検索文字列
        
        'アクティブ文書の段落を頭からなめる ActiveDocument.Paragraphs
        For n = 1 To wdApp.ActiveDocument.Paragraphs.Count
            str段落文字列 = wdApp.ActiveDocument.Paragraphs(n).Range.Text
            '単純にInstrで探してみた
            n先頭位置 = InStr(1, str段落文字列, wd) '初回は一文字目から探す
            While n先頭位置 <> 0 '検索位置が見つかっている間 0以外の時ループ
                If n先頭位置 > 0 Then '↑で文字が見つかったら、
                    wdApp.ActiveDocument.Paragraphs(n).Range.Select   '見つけたので段落選択する
                    '↑段落全体が選択されているので、↓選択範囲、start位置を移動
                    wdApp.Selection.MoveStart Unit:=wdCharacter, Count:=n先頭位置 - 1
                    '結果をExcelへ書く、
                    p = wdApp.Selection.Range.Information(wdActiveEndPageNumber)
                    l = wdApp.Selection.Range.Information(wdFirstCharacterLineNumber)
                    With ThisWorkbook.Worksheets("結果")
                        .Range("A" & iRow) = p & "P、" & l & "行目"
                        .Range("B" & iRow) = wd
                    End With
                    iRow = iRow + 1
                End If
                            
                '次の位置(見つけた位置+検索文字数)から検索文字を探す
                n先頭位置 = InStr(n先頭位置 + Len(wd), str段落文字列, wd) '同じ段落に検索文字があるかもしれないので
            
            Wend
            
        Next n
        
        'ルビを探る、探す 2022/01/24 追加
        For n = 1 To ActiveDocument.Fields.Count
            strルビ情報 = wdApp.ActiveDocument.Fields(n).Code 'フォントやフリガナ情報含む
            If InStr(strルビ情報, wd) > 0 Then 'Filed ルビの情報 から 検索ワードが見つかったら
                wdApp.ActiveDocument.Fields(n).Select  '単純にSelectで選択状態にする
                '結果をExcelへ書く、
                p = wdApp.Selection.Range.Information(wdActiveEndPageNumber)
                l = wdApp.Selection.Range.Information(wdFirstCharacterLineNumber)
                With ThisWorkbook.Worksheets("結果")
                    .Range("A" & iRow) = p & "P、" & l & "行目"
                    .Range("B" & iRow) = wd
                End With
                iRow = iRow + 1
            End If
        Next n


    Next



    MsgBox "処理終了、結果を確認してください"

End Sub

動画まで作成してカッコつけたのに(ぉぃぉぃ)
テスト不足ですみません。※回答を修正しました

恥の上塗りになるかもしれませんが、再チャレンジしてみました
https://www.youtube.com/watch?v=QcljoRs1Rsc
↑時間があるときに、ダメ動画も確認してみてください。

Comments

[jumpeiiii]

ken3memo様
動画の作成までしていただきありがとうございました。
動作イメージは、作成していただいたものの通りです。
ただ、いただいたものを試したところ、word側の文章にルビがふられていた場合、その文字列は検索されませんでした。
例えば、word文書の中に、挨拶という文字列が３か所あって、これを検索文字列として検索しようとすると、１か所の挨拶には「あいさつ」とルビがふられていた場合、そこが飛ばされて２か所しか検索されませんでした。
いただいたコードを参考に、ルビがふられた文字列も検索されるほかの方法があるか自分でも考えてみたいと思います。ありがとうございました。

[ken3memo]

あっ、ルビがふられているとダメですね
動画まで作成してカッコつけたのに(ぉぃぉぃ)
テスト不足ですみません。※回答を修正しました

恥の上塗りになるかもしれませんが、再チャレンジしてみました
https://www.youtube.com/watch?v=QcljoRs1Rsc
↑時間があるときに、ダメ動画も確認してみてください。

[jumpeiiii]

ken3memo様
修正いただきましてありがとうございました。
この間、最初に投稿いただいたものも参考に、自分でも修正を試みており、自己解決できましたので、掲載させていただきます。
修正いただいたコードでルビのものも検索結果として出力されましたが、検索結果として出力される順番が、ルビのものが最後になってしまいますので、自己解決とさせていただきました。お時間をいただき、いろいろとご尽力くださったのに申し訳ございません。
ルビ情報の取得やコーディングの考え方など大変勉強になりました。
ありがとうございました。また、機会がありましたらどうぞよろしくお願いします。