【Excel VBA】置換リストでWord文書内の指定箇所を一括置換するマクロ事例

Excelで準備した置換リストを用いてWord文書内の指定箇所を自動で一括置換することができれば、編集作業の効率化やミス防止に役立ちます。

ExcelのVBAで、置換リスト（Excel）にもとづいてWord文書内の指定箇所を修正するマクロのサンプルです。

内容

マクロの前提とアウトプットイメージ
マクロが活用できる場面
VBAサンプル
VBAの補足説明
- Comment.Scope プロパティについて

動作確認のExcelは「Microsoft® Excel® for Microsoft 365 MSO」（バージョン2501）です。

マクロの前提とアウトプットイメージ

Word文書内で置換したい場所と置換後の文字列を示す次のようなExcelリストを事前に準備します。

Excelのシートで、置換の指定場所、置換後の文字列の一覧があります — Excelの置換リスト（置換の指定場所、置換後の文字列）

Word文書にも事前に文字列を置換したい文章範囲にコメントをつけています（下図の上側）。このコメントには、「置換したい場所」を示す固有の文章でコメントしています。

この前提で、Excelの置換リストで、Wordのコメント欄に指定の値を含んでいたら、そのコメントが選択している文章範囲を指定した値に置換する、という処理をします。

マクロ実行の結果、下図の上側の文章を下側に変換します。

コメントで選択された範囲の文章が置換リストにもとづいて修正されています。

マクロが活用できる場面

このマクロの活用が適した場面は、Wordファイル（様式）の指定した位置に、リストにもとづいた定型の文章を都度挿入し、新規ファイルを作成するような繰り返し作業です。そして、

標準機能にあるWordの差し込み印刷機能より、リストを柔軟に修正したい。
文章内の文字列を直接検索、修正する一括置換では、置換したくない文字列が含まれて使いづらい

といった場面です。

VBAサンプル

サンプルは次のとおりです。

Dim 置換リスト As Variant

Sub 場所指定の置換リストでWord文書の文字列を一括置換()

    Dim wrd As Object
    Set wrd = CreateObject("Word.Application")
    
    Dim ファイル名 As Variant
    Dim 最終行 As Long

'置換リストを2次元配列に変換'
    With Sheets("置換リスト")
        最終行 = .Cells(Rows.Count, 1).End(xlUp).Row
        置換リスト = .Range(.Cells(1, 1), .Cells(最終行, 2)).Value
    End With
  
'置換対象のWordファイルの取得'
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "置換対象のWordファイルを選択"
        .Filters.Clear
        .Filters.Add "Wordファイル", "*.docx"
    
        If .Show = -1 Then
            ファイル名 = .SelectedItems(1)
            .Filters.Clear
        Else
            .Filters.Clear
            Exit Sub
        End If
    End With

'置換対象のコメントがある文章を置換'
    Set wrd = wrd.Documents.Open(ファイル名)
    wrd.Application.Visible = True
    wrd.TrackRevisions = True '確認用で変更履歴をオン’

    Dim コメント As Variant
    
    For Each コメント In wrd.Comments
    
        For i = 2 To UBound(置換リスト, 1) '2行目からが検索文字なので’
            If InStr(コメント.Range.Text, 置換リスト(i, 1)) > 0 Then
                wrd.Range(コメント.Scope.Start + 1, コメント.Scope.End - 1).Text = 置換リスト(i, 2)
                wrd.Range(コメント.Scope.Start, コメント.Scope.Start + 1).Delete
                wrd.Range(コメント.Scope.End - 1, コメント.Scope.End).Delete
                Exit For
            End If
        Next i
        
    Next コメント

End Sub