Word VBA 複数の置換条件で文書内の文字列を一括置換する

はじめに

前回、PowerPointVBAで複数の置換条件を設定し、一括置換をする方法について考察した。

せっかくなので、WordVBAでも、複数の置換条件を設定し、文書内の文字列を一括変換する方法について、考察してみたい。

Wordにおける置換方法の考察

1.置換を行うメソッドについて

Wordにおいては、Replaceメソッドは存在しない。
Replacementオブジェクトが存在し、Findオブジェクトのプロパティとなっている。

操作方法としては、Findオブジェクトに置換前の対象となる文字列を設定、FindオブジェクトのReplacementプロパティで取得したReplacementオブジェクトに対して、置換後の文字列を設定し、FindオブジェクトのExecuteメソッドで実行することで、置換ができるようだ。
Replacementオブジェクトのリファレンスからサンプルコードを引用する。

Replacement オブジェクトを取得するには、Replacement プロパティを使用します。 次の使用例は、次に単語 "hi" が使用されている箇所を単語 "hello" で置き換えます。

Replacement オブジェクト サンプルコード

With Selection.Find 
 .Text = "hi" 
 .ClearFormatting 
 .Replacement.Text = "hello" 
 .Replacement.ClearFormatting 
 .Execute Replace:=wdReplaceOne, Forward:=True 
End With

続いて、Find.Executeメソッドについてリファレンスを参照したところ、Executeメソッドのパラメーターでも、置換の設定ができるようだ。

パラメーター「ReplaceWith」　省略可能　データ型：Variant
置換文字列を指定します。 引数 Find によって指定された文字列を削除するには、空文字列 ("") を使用します。
パラメーター「Replace」 省略可能　データ型：Variant
置換する文字列の個数 (1 つだけ、すべて、または置換しない) を指定します。 任意の WdReplace 定数を指定できます。

上記のReplacementオブジェクトのサンプルコードに似たものがExecuteメソッドにもあったので引用する。

次の使用例は、作業中の文書で単語 "hi" を検索し、すべての "hi" を "hello" に置き換えます。

Find.Executeメソッド サンプルコード

Set myRange = ActiveDocument.Content 
myRange.Find.Execute FindText:="hi", _ 
    ReplaceWith:="hello", Replace:=wdReplaceAll

こちらの方が、シンプルで分かりやすい。
WordVBAにおいて、置換はFindオブジェクトのExecuteメソッドで行うことにした。

2.Find.Executeを実行する対象について

Findオブジェクトは、Rangeオブジェクトのプロパティから取得する。

このRangeオブジェクトを置換対象となる文字列がある範囲にして、FindオブジェクトのExecuteメソッドを実行する。

このRangeオブジェクトの範囲を考える上で、Wordの構成について、以下のサイトの図がとても分かりやすく、参考になった。

Wordにはストーリーという文字を入力できる領域の区分が用意されている。このストーリーには、メインテキスト(本文)、ヘッダー・フッター、脚注、コメント、レイアウト枠といった、Word文書内の文字を入力できる領域全てが含まれているようだ。これらのストーリーはDocumentオブジェクトのStoryRangesプロパティで各ストーリーのRangeオブジェクトのコレクションとして、StoryRangesオブジェクトを取得できる。

このStoryRangesオブジェクトに対して、For Each～Nextを使い、各ストーリーのRangeオブジェクトにFindオブジェクトのExecuteメソッドを使用することで、ワード文書内の全ての範囲を対象とすることにした。

図形内の文字については、ストーリーのレイアウト枠でも一部図形を対象にしているようだが、以下の理由から、図形については別途、取得することとした。

①SmartArt、グラフタイトル・グラフ軸ラベルについては、TextFrame2.TextRangeプロパティで取得したTextRange2オブジェクトに対して、Replaceメソッドを使う必要がある

②グループ化された図形、テキストボックス等、ストーリーのレイアウト枠を対象にした置換では、置換できないものがあった

一般的な図形において、PowerPointのShepe.TextFrame.TextRangeプロパティで取得できたのはTextRangeオブジェクトだったが、WordにおけるShepe.TextFrame.TextRangeプロパティで取得できるのは、Rangeオブジェクトのため、ストーリーと同様、Find.Executeメソッドが使える。

PowerPointの際と同様、対象とするオブジェクトをコレクション化し、処理を行うことにした。
以下、対象オブジェクトをコレクション化して返すFunctionプロシージャと、グループ化された図形のため、再帰処理用のプロシージャを作成した。
作成するコレクションは、モジュールレベル変数として宣言セクションで宣言し、再帰処理用プロシージャで各図形のTextFrameオブジェクト・TextRange2オブジェクト追加し、完成したコレクションをFunctionプロシージャで返す。
(ここで図形のTextFrame.TextRangeプロパティでRangeオブジェクトを取得してもよいが、置換ではなく、指定した文字列に処理を行いたい場合、後述するが、面倒なことになるので注意！）

対象オブジェクトをコレクション化

Dim TargetCollection As Collection

Public Function GetTargetCollection(TargetDocument As Document)
Dim TargetShape As Shape

    Set TargetCollection = New Collection
    For Each TargetShape In TargetDocument.Shapes
        Call Prosess_Shape(TargetShape)
    Next TargetShape
    Set GetTargetCollection = TargetCollection
    Set TargetCollection = Nothing
End Function


Public Sub Prosess_Shape(TargetShape As Shape)
Dim GroupShape As Shape
Dim TargetAxis As IMsoAxis

    Select Case TargetShape.Type
    
        Case msoSmartArt
            For Each GroupShape In TargetShape.GroupItems 
               TargetCollection.Add GroupShape.TextFrame2.TextRange
            Next GroupShape
            
        Case msoGroup 
            For Each GroupShape In TargetShape.GroupItems
                Call Prosess_Shape(GroupShape)
            Next GroupShape
            
        Case msoChart
            If TargetShape.Chart.HasTitle Then
                TargetCollection.Add TargetShape.Chart.ChartTitle.Format.TextFrame2.TextRange
            End If
            
            For Each TargetAxis In TargetShape.Chart.Axes
                If TargetAxis.HasTitle Then
                    TargetCollection.Add TargetAxis.AxisTitle.Format.TextFrame2.TextRange
                End If
            Next TargetAxis
            
        Case Else
            If TargetShape.TextFrame.HasText Then
                TargetCollection.Add TargetShape.TextFrame
            End If
            
    End Select
End Sub

3.置換実行用コードについて

以下に置換実行用コードを示す。
Find.Executeメソッドのパラメーター「Replace」に「wdReplaceAll」を指定することで、一括で置き換えられるのだが、コメントのストーリーに対してだけは、一括で置換ができないようなので、1件ずつ置換を実行し、置き換える文字列がなくなるまで繰り返すようにした。
　
コレクション化した図形の対象オブジェクトについては、SmartArt、グラフタイトル・グラフ軸ラベルはTextRange2オブジェクトのため、TextRange2オブジェクトのReplaceメソッドを使用する。TextRange2オブジェクトにおけるReplaceメソッドの使い方は、前回のPowerPointVBAの記事を参照のこと。
他の図形はRangeオブジェクトなので、Find.Executeメソッドを使い、一括で置換ができる。

置換実行用

Public Sub Run_Replace()
Dim TargetDocument As Document
Dim TargetCollection As Collection
Dim i As Long
Dim Conditions As Collection
    
    Set TargetDocument = ActiveDocument
    Set TargetCollection = GetTargetCollection(TargetDocument) 
    Set Conditions = New Collection
    
    '検索する単語、置き換えたい単語
    Conditions.Add Array("うえ", "した")
    Conditions.Add Array("きく", "ゆり")
   
    For i = 1 To Conditions.Count   
        Call Prosess_Replace(TargetDocument, TargetCollection, Conditions(i)(0), Conditions(i)(1))
    Next i
    Set Conditions = Nothing
    Set TargetCollection = Nothing
End Sub

Public Sub Prosess_Replace(TargetDocument As Document, TargetCollection As Collection, TargetWord As Variant, ReplaceWord As Variant)
Dim TargetStory As Range
Dim TargetItem As Object
Dim ReplaceRange As TextRange2

    For Each TargetStory In TargetDocument.StoryRanges
    
        'コメントは一括置換できないため別処理
        If TargetStory.StoryType = wdCommentsStory Then
                TargetStory.Find.Execute FindText:=TargetWord, ReplaceWith:=ReplaceWord, Replace:=wdReplaceOne, MatchCase:=msoTrue, Wrap:=wdFindStop
                Do While TargetStory.Find.Found
                    Set TargetStory = TargetDocument.StoryRanges(wdCommentsStory)
                    TargetStory.Find.Execute FindText:=TargetWord, ReplaceWith:=ReplaceWord, Replace:=wdReplaceOne, MatchCase:=msoTrue, Wrap:=wdFindStop
                Loop
        Else
            TargetStory.Find.Execute FindText:=TargetWord, ReplaceWith:=ReplaceWord, Replace:=wdReplaceAll, MatchCase:=msoTrue
        End If
    Next TargetStory

    For Each TargetItem In TargetCollection
        Select Case TypeName(TargetItem)
        
            Case "TextRange2"
                Set ReplaceRange = TargetItem.Replace(TargetWord, ReplaceWord, MatchCase:=msoTrue)
                Do Until ReplaceRange Is Nothing
                    Set ReplaceRange = TargetItem.Replace(TargetWord, ReplaceWord, ReplaceRange.Start + ReplaceRange.Length - 1, MatchCase:=msoTrue)
                Loop

            Case "TextFrame"
                TargetItem.TextRange.Find.Execute FindText:=TargetWord, ReplaceWith:=ReplaceWord, Replace:=wdReplaceAll, MatchCase:=msoTrue
        
        End Select
     Next TargetItem
     
End Sub

応用編：指定した文字を一括して上付き下付きにする

さて、指定した文字列に何らかの処理をする場合の方法についてだが、まずは、Findオブジェクトのリファレンスから以下を引用したい。

Range オブジェクトから Find オブジェクトを取得した場合、検索条件と一致する文字列が見つかっても選択範囲は変更されませんが、Range オブジェクトが再定義されます。

Rangeオブジェクト.Find.Excuteメソッドを実行して、検索条件と一致する文字列が見つかると、Rangeオブジェクトが見つかった文字列のRangeオブジェクトとして再定義されるらしい。さらに、試したところ、この再定義されたRangeオブジェクトでFind.Excuteメソッドを実行すると、見つかった文字列の後から検索できるようだ。この仕組みを使って、順繰りに指定した文字列の処理を行うことができる。

WordVBAには、PowerPointの際のBaselineOffsetプロパティはなかったので、Superscriptプロパティ(上付き)、Subscriptプロパティ(下付き)を使用した。

図形のRangeオブジェクトについてだが、当初、Rangeオブジェクトをコレクション化して処理しようとしたところ、コレクション化したRangeオブジェクトに対して、Find.Executeメソッドを実行すると、コレクション内のRangeオブジェクトが再定義されてしまったのだ。
そのため、次の置換条件で実行する際に、Rangeオブジェクトの開始位置が前の置換条件で見つかった位置からとなってしまい、図形の文字列の最初から検索されないという問題が発生した。
そこで、コレクション化するのはTextRangeオブジェクトの親オブジェクトであるTextFrameオブジェクトに変更し、Executeメソッドを実行する際に、Rangeオブジェクトを変数にセットして実行することで、コレクション内のオブジェクトが変更されないようにした。

上付き下付き変更

Public Sub Run_SuperSubscript()
Dim TargetDocument As Document
Dim TargetCollection As Collection
Dim Conditions As Collection
Dim i As Long
    
    Set TargetDocument = ActiveDocument
    Set TargetCollection = GetTargetCollection(TargetDocument)
    Set Conditions = New Collection
    
   '検索する単語、検索した単語の上付き・下付きにしたい文字の位置、文字の長さ、上付き・下付き・標準
    Conditions.Add Array("CO2", 3, 1, "下付き")
    Conditions.Add Array("m2", 2, 1, "上付き")
    Conditions.Add Array("m3", 2, 1, "上付き")
    Conditions.Add Array("H2O", 2, 1, "下付き")
    
    For i = 1 To Conditions.Count
        Call Change_SuperSubscript(TargetDocument, TargetCollection, Conditions(i)(0), Conditions(i)(1), Conditions(i)(2), Conditions(i)(3))

    Next i
    Set Conditions = Nothing
    Set TargetCollection = Nothing
    
End Sub


Public Sub Change_SuperSubscript(TargetDocument As Document, TargetCollection As Collection, TargetWord As Variant, TargetStart As Variant, TargetLength As Variant, SetType As Variant)
Dim TargetStory As Range
Dim TargetItem As Object
Dim FindRange As Object
Dim i As Long

    For Each TargetStory In TargetDocument.StoryRanges
        TargetStory.Find.Execute FindText:=TargetWord, Wrap:=wdFindStop, MatchCase:=msoTrue
        Do While TargetStory.Find.Found
            For i = TargetStart To TargetStart + TargetLength - 1
                Select Case SetType
                    Case "下付き"
                        TargetStory.Characters.Item(i).Font.Subscript = True
                    Case "上付き"
                        TargetStory.Characters.Item(i).Font.Superscript = True
                    Case "標準"
                        TargetStory.Characters.Item(i).Font.Subscript = False
                        TargetStory.Characters.Item(i).Font.Superscript = False
                End Select
            Next i
            TargetStory.Find.Execute FindText:=TargetWord, Wrap:=wdFindStop, MatchCase:=msoTrue
       Loop
    Next TargetStory

    
    For Each TargetItem In TargetCollection
        Select Case TypeName(TargetItem)
            Case "TextRange2"
                Set FindRange = TargetItem.Find(TargetWord, MatchCase:=msoTrue)
                Do Until FindRange = ""
                    Select Case SetType
                        Case "下付き"
                            FindRange.Characters(TargetStart, TargetLength).Font.Subscript = msoTrue
                        Case "上付き"
                            FindRange.Characters(TargetStart, TargetLength).Font.Superscript = msoTrue
                        Case "標準"
                            FindRange.Characters(TargetStart, TargetLength).Font.Subscript = msoFalse
                            FindRange.Characters(TargetStart, TargetLength).Font.Superscript = msoFalse
                    End Select
                    Set FindRange = TargetItem.Find(TargetWord, FindRange.Start + FindRange.Length - 1, MatchCase:=msoTrue)
                Loop

            Case "TextFrame"
                 Set FindRange = TargetItem.TextRange
                 FindRange.Find.Execute FindText:=TargetWord, Wrap:=wdFindStop, MatchCase:=msoTrue
                 Do While FindRange.Find.Found
                     For i = TargetStart To TargetStart + TargetLength - 1
                         Select Case SetType
                         Case "下付き"
                             FindRange.Characters.Item(i).Font.Subscript = True
                         Case "上付き"
                             FindRange.Characters.Item(i).Font.Superscript = True
                         Case "標準"
                             FindRange.Characters.Item(i).Font.Subscript = False
                             FindRange.Characters.Item(i).Font.Superscript = False
                         End Select
                     Next i
                     FindRange.Find.Execute FindText:=TargetWord, Wrap:=wdFindStop, MatchCase:=msoTrue
                Loop
        End Select
     Next TargetItem
     
End Sub