ワードの原稿に変更履歴で修正を入れることがあります。複数出てくる名称等は、変更履歴をオンにしてCtr+Hなどで一括置換すると便利です。

しかしながら、一括置換も多用しすぎると、文書が変更履歴だらけになってしまいます。

例えば、「制御装置」を「制御部」に変えるとき、「制御」はそのままで、「装置」だけ「部」に変えてほしい。

前方一致部分には変更履歴をかけず、後方の相違部分のみに変更履歴をかけるマクロです。

Sub 後の差分だけ変更履歴置換()
Dim i As Long
Dim Tr As Boolean
Dim Sh As Boolean
Dim 変更前語句 As String
Dim 変更後語句 As String
Dim 一致部分 As String
Dim 変更部分前 As String
Dim 変更部分後 As String


変更前語句 = InputBox("変更前語句を入力してください")
変更後語句 = InputBox("変更後語句を入力してください")
If Len(変更前語句) = 0 Or Len(変更後語句) = 0 Then MsgBox ("変更前語句又は変更後語句の入力がないため処理を終了します"): Exit Sub
If Left(変更前語句, 1) <> Left(変更後語句, 1) Then MsgBox ("前方不一致のため処理を終了します"): Exit Sub

'前方の一致部分と、後方の相違部分を分離します
For i = 2 To Len(変更前語句)
    If i > Len(変更後語句) Then Exit For
    If Mid(変更前語句, i, 1) <> Mid(変更後語句, i, 1) Then Exit For
Next i
i = i - 1
一致部分 = Left(変更前語句, i)
If i = Len(変更前語句) Then
    変更部分前 = ""
Else
    変更部分前 = Mid(変更前語句, i + 1, Len(変更前語句) - i)
End If

If i = Len(変更後語句) Then
    変更部分後 = ""
Else
    変更部分後 = Mid(変更後語句, i + 1, Len(変更後語句) - i)
End If


With ActiveDocument
    Tr = .TrackRevisions
    Sh = .ShowRevisions
    ActiveDocument.TrackRevisions = True
    ActiveDocument.ShowRevisions = True
    
    Call 後ろだけ置換する(一致部分, 変更部分前, 変更部分後)
    
    .TrackRevisions = Tr
    .ShowRevisions = Sh
End With
End Sub

Sub 後ろだけ置換する(ByRef 検索文字 As String, ByRef 変更前 As String, ByRef 変更後 As String)
Dim rng As Range
Dim rngCur As Range
Dim rngEnd As Long
Dim 選択位置 As Long
Dim noSelection As Boolean: noSelection = False

Set rngCur = Selection.Range

With ActiveDocument
If InStr(1, .StoryRanges(wdMainTextStory).Text, 検索文字, vbTextCompare) > 0 Then
    If Len(Selection.Text) < 3 Then
        Set rng = .Range(0, .Bookmarks("\EndOfDoc").End)
        noSelection = True
    Else
        Set rng = Selection.Range
    End If
    rngEnd = rng.End
    
    Do
        If 語句あるか(検索文字, rng) = True Then
            選択位置 = Selection.Range.End
            Set rng = .Range(選択位置 + Len(変更後), rngEnd)
            If .Range(選択位置, 選択位置 + 1).Text = "" Then 選択位置 = 選択位置 + 1
            If .Range(選択位置, 選択位置 + Len(変更前)).Text = 変更前 And (.Range(選択位置, 選択位置 + Len(変更後)).Text <> 変更後 Or 変更後 = "") Then
                If 変更前 <> "" Then .Range(選択位置, 選択位置 + Len(変更前)).Text = ""
                .Range(選択位置, 選択位置 + Len(変更前)).InsertAfter (変更後)
            End If
            If noSelection = True Then rngEnd = .Bookmarks("\EndOfDoc").End
        Else
            Exit Do
        End If
    Loop
    
    Set rng = Nothing
End If
End With

rngCur.Select
Set rngCur = Nothing
End Sub

Function 語句あるか(ByRef 検索文字 As String, ByRef rng As Range) As Boolean
If Not rng Is Nothing Then rng.Select
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = 検索文字
    .Format = False
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = False 
    .MatchFuzzy = True
    語句あるか = .Execute
    
    .Text = ""
    .MatchFuzzy = False 
End With
End Function

例えば、↓のような文書を用意して、マクロを実行します。

すると、変更前語句を聞かれますので、例えば制御装置と入力します。

続いて、変更後語句を聞かれますので、制御部と入力します。

実行結果は、↓のとおりです。「制御」には、変更履歴がかからず、「装置」が削除され、「部」が追加されます。