“Find and Replace” multiple words in Word from Excel list

Question

I have created a find and replace Macro in MS Word that replaces word A with B. Ok, but now I have 50 words that need replacing. That means I will have to create a new entry for each word, which will take FOREVER. Plus a few weeks from now I will have to add more words to be replaced.

Is there a way to link a word list via excel, say words in column 1 are the words I want replaced with the matching words in column 2?

Here's what I have so far.

Sub Macro5()
'
' Macro5 Macro
'
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "apples"
        .Replacement.Text = "all the apples"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Execute
End Sub

Answer 1

1. Revise your macro so that it can accept parameters for "word to find" and "word to replace with".
2. Loop through a range in excel, passing the value of each cell to your revised macro(subroutine).

Answer 2

Something like this should get you started. Bind Excel to Word, open the file which contains the list, and iterate over the list, calling your macro (modified to accept two string arguments, findText and replaceText ) sequentially.

Sub Main()
Dim xl as Object 'Excel.Application
Dim wb as Object 'Excel.Workbook
Dim ws as Object 'Excel.Worksheet
Dim rng as Object 'Excel.Range
Dim cl as Object  'Excel.Range
Set xl = CreateObject("Excel.Application")
Set wb = xl.Workbooks.Open("c:\folder\file.xlsx") '## Modify as needed
Set ws = wb.Sheets(1) '##Modify as needed
Set rng = ws.Range("A1", ws.Range("A1").End(xlDown))
For each cl in rng
    Call Macro5(cl.Value, cl.offset(0,1).Value)
Next
End Sub

You are on your own to confirm that the contents of Macro5 works as intended within the above loop.

Sub Macro5(findText$, replaceText$)
'
' Macro5 Macro
'
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = findText
        .Replacement.Text = replaceText
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Execute
End Sub