MS Word Macro for Search and Replace

Here is a MS Word macro that worked well for search/replace function with confirmation for each change in all sections of MS Word document including headers, footers, EndNote, and Footnote, etc. in MS Word 2013, 2016, and 2019 using list of words in MS Word document in a table format. Make sure to copy and paste entire macro to avoid any typing error.

Sub SearchReplace_AllSections()

' *****************************************************************************************

' Modified by Wajeeh Bajwa (June 1, 2016) based on two macros given below and changes suggested by

' Doug Robbins - Word MVP on  May 31, 2016 at:

' http://answers.microsoft.com/en-us/office/forum/office_2010-word/word-20...

'

' This macro is a combination of two macros:

' Macro 1 written by Graham Mayor, Aug 2010: http://www.word.mvps.org/FAQs/MacrosVBA/FindReplaceAllWithVBA.htm

' Macro 2 written by Rhonda (March 28, 2015): https://cybertext.wordpress.com/2015/03/03/word-macro-to-run-multiple-wi...

' ******************************************************************************************

Dim oChanges As Document, oDoc As Document

Dim myStoryRange As Range

Dim oTable As Table

Dim oRng As Range

Dim rFindText As Range, rReplacement As Range

Dim i As Long

Dim sFname As String

'Change the path in the line below to reflect the name and path of the document that contains list of original text and replacement text in a table

sFname = "C:\Add_Spaical_Characters.docx"

Set oDoc = ActiveDocument

Set oChanges = Documents.Open(FileName:=sFname, Visible:=False)

Set oTable = oChanges.Tables(1)

For i = 1 To oTable.Rows.Count

    Set oRng = oDoc.Range

    Set rFindText = oTable.Cell(i, 1).Range

    rFindText.End = rFindText.End - 1

    Set rReplacement = oTable.Cell(i, 2).Range

    rReplacement.End = rReplacement.End - 1

    Selection.HomeKey wdStory

    'First search the main document using the Selection

    With Selection.Find

        .Text = rFindText

        .Replacement.Text = rReplacement

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

         With oRng.Find

            .ClearFormatting

            .Replacement.ClearFormatting

            Do While .Execute(findText:=rFindText, _

                              MatchWholeWord:=True, _

                              MatchWildcards:=False, _

                              Forward:=True, _

                              Wrap:=wdFindStop) = True

               oRng.Select

                sAsk = MsgBox("Replace: " & vbCr & oRng & vbCr + vbCr & _

                              "with: " & vbCr & rReplacement, vbYesNo + vbQuestion, _

                              "Replace from Table")

                If sAsk = vbYes Then

                    oRng = rReplacement

               End If

                oRng.Collapse wdCollapseEnd

            Loop

        End With

    End With

    'Now search all other stories using Ranges

    For Each myStoryRange In ActiveDocument.StoryRanges

        If myStoryRange.StoryType <> wdMainTextStory Then

            With myStoryRange.Find

                .Text = rFindText

                .Replacement.Text = rReplacement

                .Wrap = wdFindContinue

                 With myStoryRange.Find

            .ClearFormatting

            .Replacement.ClearFormatting

            Do While .Execute(findText:=rFindText, _

                              MatchWholeWord:=True, _

                              MatchWildcards:=False, _

                              Forward:=True, _

                              Wrap:=wdFindStop) = True

 'Changed to myStoryRange.Select from oRng.Select on the next line

               myStoryRange.Select

                sAsk = MsgBox("Replace: " & vbCr & myStoryRange & vbCr + vbCr & _

                              "with: " & vbCr & rReplacement, vbYesNo + vbQuestion, _

                              "Replace from Table")

                If sAsk = vbYes Then

                    myStoryRange = rReplacement

               End If

                myStoryRange.Collapse wdCollapseEnd

            Loop

        End With

            End With

            Do While Not (myStoryRange.NextStoryRange Is Nothing)

                Set myStoryRange = myStoryRange.NextStoryRange

                With myStoryRange.Find

                    .Text = rFindText

                    .Replacement.Text = rReplacement

                    .Wrap = wdFindContinue

                     With myStoryRange.Find

            .ClearFormatting

            .Replacement.ClearFormatting

            Do While .Execute(findText:=rFindText, _

                              MatchWholeWord:=True, _

                              MatchWildcards:=False, _

                              Forward:=True, _

                              Wrap:=wdFindStop) = True

               myStoryRange.Select

                sAsk = MsgBox("Replace: " & vbCr & myStoryRange & vbCr + vbCr & _

                              "with: " & vbCr & rReplacement, vbYesNo + vbQuestion, _

                              "Replace from Table")

                If sAsk = vbYes Then

                    myStoryRange = rReplacement

               End If

                myStoryRange.Collapse wdCollapseEnd

            Loop

        End With

                End With

            Loop

        End If

    Next myStoryRange

Next i

oChanges.Close wdDoNotSaveChanges

ActiveWindow.View = wdPrintView

Selection.HomeKey wdStory

MsgBox "All requested changes have been made!" & Chr(13) & Chr(13) & "Macro v1.00 to add special characters created" & Chr(13) & "by Dr. Wajeeh Bajwa, Jacksonville, FL", vbOKOnly, "Macro Completed"

End Sub