[Excel VBA]WORD文書の赤字の頁番号を列挙する「赤字以外の属性不可」

投稿日 2022年6月4日 07:36 by おっとっとっと

WORD文書の中の赤字を見つけるマクロを見つけた。

添削するには便利、しかしそんな便利なマクロを作ってる人は稀なので大抵は

P１０、１２を修正

の様に列挙したリストも渡さないといけないので、そんなマクロを作ってみた。

WORD文書には

ヘッダかフッタに頁番号のフィールドを割り当てておく。

マクロを配置するEXCELのワークシートには

な感じで対象WORD文書名、赤字、頁番号と書いたセルにタイトル行と名付け、対象WORD文書名の下に赤字を探すWORD文書のファイル名を入れておく。

赤文字頁番号検索マクロを実行すると

図の様に見つけた赤字とその頁番号がワークシートに書き込まれる。

そんなマクロのメイン処理はこんな感じ。

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

察しが付いたと思うがとても長いし、WORD「選択」で複数個の選択状態になった場合、VBAでその結果にダイレクトにアクセスする方法がみあたらなかったので、一旦クリップボードに入れてワークシートに書き出し、１つづつ頁番号を調べているので、処理が終わるまでじっと待たなければいけない。

以下、サブルーチン群。

セル名を使っているけど、単なる趣味でしかない。

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

普通にWORD文書を開くとマクロのデバッグでSTOPしたりすると時々ＥＸＣＥＬの裏に「壊れたWORD文書です。ｘｘｘｘｘ」と表示されたりするので、読み取り専用で開くのが吉。

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

WORDの「高度な検索」で「書式」から赤字を指定した場合のマクロ

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

WORDの「類似した書式の文字列を選択」のマクロ

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

意外と面倒なWORDの終了

ループしなくても

wordApp.Documents.Close SaveChanges:=wdDoNotSaveChanges

で済むらしいけど、念のためループしている。

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




コメントを残す

メールアドレスが公開されることはありません。 ※ が付いている欄は必須項目です

CAPTCHA