Wordで複数の単語をまとめて置換するユーザーフォームを使ったマクロ

やたらタイトルが長くなったけど、
要は置換する対象の単語がたくさんあって、1つずづ置換するのは面倒だからまとめて一気に置換させる。
さらにユーザーフォームを使って使いやすくして、置換する単語もCSVでインポートできる。
アドインの形式で使う。

こんなボタンがツールバーにできて。

こんなフォームが出てくる。

全置換実行ボタンを押すと、変換する。しかもWordの変更履歴にすべて記録する。
同時に、入力した項目をファイルに保存する。

ソースコード

ファイル添付できないので、ソースをのせます。

まず、ユーザーフォームを作ってください。

コントロール	オブジェクト名	説明
UserForm	UserForm1
TextBox	Before	置換前の単語を入力する
TextBox	After	置換後の単語を入力する
ListBox	WordList	置換項目の一覧を表示する
CommandButton	Add	項目をリストに追加する
CommandButton	Delete	項目をリストから削除する
CommandButton	Import	項目を記述したCSVファイルをインポートする
CommandButton	Replace	置換を実行する

ユーザーフォームに以下のコードを記述してください。

Option Explicit

Private Sub Add_Click()
    If Before.Value = "" Then
        MsgBox "置換前の文字列を入力してください"
    Else
        WordList.AddItem (Before.Value)
        WordList.List(WordList.ListCount - 1, 1) = After.Value
        Before.Value = ""
        After.Value = ""
    End If
    
    Before.SetFocus
    
End Sub

Private Sub Delete_Click()
    If WordList.ListIndex = -1 Then
        MsgBox "削除する項目を選択してください"
    Else
        WordList.RemoveItem (WordList.ListIndex)
    End If
End Sub

Private Sub Import_Click()
    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
    If Application.FileDialog(msoFileDialogOpen).Show = -1 Then
        
        Dim FileNumber As Integer
        FileNumber = FreeFile
        
        Open Application.FileDialog(msoFileDialogOpen).SelectedItems(1) For Input As #FileNumber
    
        Dim LineNumber As Long
        LineNumber = 1
        Dim LineContent As String
        
        Do Until EOF(FileNumber)
            Line Input #FileNumber, LineContent
            
            LineNumber = LineNumber + 1
            
            Dim Items() As String
            Items = Split(LineContent, ",")
            WordList.AddItem (Items(0))
            WordList.List(WordList.ListCount - 1, 1) = Items(1)
        Loop
        
        Close #FileNumber
    End If

    
End Sub

Private Sub Replace_Click()

    If IsEmpty(WordList) Then
        MsgBox "置換する項目が1つもありません"
        Exit Sub
    ElseIf WordList.ListCount < 1 Then
        MsgBox "置換する項目が1つもありません"
        Exit Sub
    End If
    
    
    With ActiveDocument
        .TrackRevisions = True
        .ShowRevisions = True
        CommandBars("Reviewing").Visible = True
    End With
    
    Dim Items As Variant
    Items = WordList.List
            
    Dim i As Integer
    For i = LBound(Items) To UBound(Items)
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = Items(i, 0)
            .Replacement.Text = Items(i, 1)
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchByte = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = False
            .MatchFuzzy = False
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
    Next
    
    Dim File As Object
    Set File = CreateObject("Scripting.FileSystemObject")
    
    Dim Stream As Object
    Set Stream = File.CreateTextFile(ThisDocument.Path & "\全置換マクロ項目.txt", True)
    
    For i = LBound(Items) To UBound(Items)
        Stream.WriteLine Items(i, 0) & "," & Items(i, 1)
    Next
    
    Stream.Close: Set File = Nothing: Set Stream = Nothing
    
    Unload Me
    
End Sub

Private Sub UserForm_Initialize()
    WordList.ColumnCount = 2
    Before.IMEMode = fmIMEModeOn
    After.IMEMode = fmIMEModeOn
End Sub

ドキュメント(ThisDocument)に次のコードを記述してください。

Sub UserForm_Show()
    UserForm1.Show
End Sub

'アドインをインストールしたときに自動実行させる
Sub AutoExec()
    
    On Error Resume Next
    
    Dim Bar As CommandBar
    Set Bar = Application.CommandBars("マクロ")
    
    If Bar Is Nothing Then
        Set Bar = Application.CommandBars.Add("マクロ")
        Bar.Position = msoBarTop
            
        Dim Menu As CommandBarButton
        Set Menu = Bar.Controls.Add(Type:=msoControlButton)
        Menu.Caption = "全置換(&R)"
        Menu.OnAction = "UserForm_Show"
        Menu.Width = 60
        Menu.BeginGroup = True
        Menu.Style = msoButtonCaption
    End If
    
    Bar.Visible = True
    
End Sub

このファイルを文書テンプレート(.dot)形式で保存します。

アドインとして利用できるので、Wordでツール→テンプレートとアドインから作成したファイルを追加します。

すると、ツールバーに全置換ボタンが出てきたはずです！
ボタンを押すか、「Alt + R」のショートカットキーで起動します。

全置換実行ボタンを押すと文書と同じディレクトリに「全置換マクロ項目.txt」にCSV形式で置換項
目を保存します。
単なる2列のCSV形式なので、ほかのアプリからでも出力できると思います。