変奏現実

Public Sub 赤文字頁番号検索()
On Error GoTo err1

    '初期化
    Dim wordApp As Word.Application
    Set wordApp = CreateObject("Word.Application")
    '
    Dim 赤字の開始行 As Long
    赤字の開始行 = ActiveSheet.Range("タイトル行").row + 1

    Dim 赤字の列 As Long
    赤字の列 = ActiveSheet.Range("タイトル行").Find("赤字").Column
    
    Dim 頁番号の列 As Long
    頁番号の列 = ActiveSheet.Range("タイトル行").Find("頁番号").Column

    '検索対象のWORD文書を開く
    Dim wordFname As String
    wordFname = 検索対象のWORD文書名を調べる
    Dim wordDoc As Word.document
    Set wordDoc = 検索対象のWORD文書を開く(wordApp, wordFname)
    If TypeName(wordDoc) <> "Nothing" Then
        '赤文字を１文字選択する
        Call 赤文字を1文字選択する(wordDoc)
        '選択中の文字と同じ属性の文字を全て選択状態にする
        Call 選択中の文字と同じ属性の文字列を全部クリップボードにコピる(wordDoc)
        'ワークシートに貼り付ける
        ActiveSheet.Cells(赤字の開始行, 赤字の列).Select
        ActiveSheet.Paste
        'ワークシートの選択状態のセルの文字を検索する
        Dim row As Long
        For row = 赤字の開始行 To 赤字の開始行 - 1 + Selection.Count
            Dim text As String
            text = ActiveSheet.Cells(row, 赤字の列).Value
            Dim 頁番号 As Integer
            頁番号 = 赤字テキスト検索(wordDoc, text)
            If 頁番号 > 0 Then
                '右セルに頁番号を書き込む
                ActiveSheet.Cells(row, 頁番号の列).Value = 頁番号 & "頁"
            Else
                ActiveSheet.Cells(row, 頁番号の列).Value = "見つかりません"
            End If
            'ワークシートの選択状態の最後のセルまで繰り返す
        Next row
    End If
exit1:
    Call MSWORDをそのまま閉じる(wordApp)
    Exit Sub

err1:
    MsgBox Err.Description
    GoTo exit1

End Sub

Private Function 検索対象のWORD文書名を調べる() As String
    
    Dim ファイル名列 As Integer
    ファイル名列 = ActiveSheet.Range("タイトル行").Find("対象WORD文書名").Column
    Dim wordFname As String
    wordFname = ActiveSheet.Cells(ActiveSheet.Range("タイトル行").row + 1, ファイル名列)
    'ドライブレターやパスが無い場合
    If InStr(wordFname, "\") = 0 Then
        wordFname = ActiveWorkbook.Path & "\" & wordFname
    End If
    検索対象のWORD文書名を調べる = wordFname

End Function

Private Function 検索対象のWORD文書を開く(wordApp As Word.Application, docPath As String) As Word.document
On Error GoTo err1

    '読み取り専用
    Set 検索対象のWORD文書を開く = wordApp.Documents.Open(Filename:=docPath, ReadOnly:=True)
    Exit Function

err1:
    MsgBox Err.Description
    Set 検索対象のWORD文書を開く = Nothing

End Function

Private Sub 赤文字を1文字選択する(wordDoc As Word.document)

    '赤文字を検索
    wordDoc.ActiveWindow.Selection.Find.ClearFormatting
    wordDoc.ActiveWindow.Selection.Find.Font.Color = wdColorRed
    
    With wordDoc.ActiveWindow.Selection.Find
        .text = ""
        .Replacement.text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = True
    End With
    
    wordDoc.ActiveWindow.Application.Selection.Find.Execute
    
    '１文字だけ選択する
    wordDoc.ActiveWindow.Selection.End = wordDoc.ActiveWindow.Selection.Start + 1

End Sub

Private Sub 選択中の文字と同じ属性の文字列を全部クリップボードにコピる(wordDoc As Word.document)

    '類似した書式の文字列を選択するWordマクロ三種     https://www.ka-net.org/blog/?p=5486
    wordDoc.Application.Run "SelectSimilarFormatting"
    'Application.CommandBars.FindControl(ID:=5946).Execute
    'Application.CommandBars.ExecuteMso "SelectTextWithSimilarFormatting"
    
    'クリップボードにコピる
    wordDoc.ActiveWindow.Selection.Copy

End Sub

Private Function 赤字テキスト検索(wordDoc As Word.document, text As String) As Integer

    赤字テキスト検索 = 0
    With wordDoc.Content.Find
        '赤文字を指定
        .ClearFormatting
        .Font.Color = wdColorRed
        'テキストを指定
        .text = text
        '順方向を指定
        .Forward = True
        'いざ検索
        .Execute
        '結果は？
        If .Found = True Then
            wordDoc.ActiveWindow.Selection.Start = .Parent.Start
            wordDoc.ActiveWindow.Selection.End = .Parent.End
            '頁番号を返す
            赤字テキスト検索 = wordDoc.ActiveWindow.Selection.Information(wdActiveEndAdjustedPageNumber)
            Exit Function
        End If
    End With

End Function

Private Sub MSWORDをそのまま閉じる(ByRef wordApp As Word.Application)

    Dim idx As Integer
    For idx = 1 To wordApp.Documents.Count
        wordApp.Documents(idx).Close SaveChanges:=wdDoNotSaveChanges
    Next
    wordApp.Quit
    Set wordApp = Nothing

End Sub