Find and Replace?

Question

Does anyone know of a way to do a more complex find and replace? For example, I have many documents with merge fields. I need to be able to change the merge fields in these documents based on a list of definitions\translations. So in this example lets say I have 100 equipment leases created in M$ word saved as .dot. Each one the following merge fields exists, and I want to change them all at once to a new value as shown below.

{MERGEFIELD state} -> {MERGEFIELD ownerstate}
{MERGEFIELD city} -> {MERGEFIELD ownercity}
{MERGEFIELD zip} -> {MERGEFIELD ownerzip}

It's not so important that I be able to edit more than 1 document at a time than it is that I be able to make multiple edits at once.

Answer 1

OK so I was able to create a solution to my own issue. To do this I created the following code to do a find and replace based on a definition list in excel.

Option Explicit
Private MyXL As Object

Sub Test()
Dim WB As Excel.Workbook, WS As Excel.Worksheet, MyDefTbl As Excel.Range, MyRow As Excel.Range
Dim MySearchRng As Excel.Range, ReplacementRng As Excel.Range

Dim myDoc As Document

Call MyInitializeOfficeApps

'Define the Workbook that contains the Definitions
Set WB = MyXL.Workbooks.Open("E:\MailMerges\Definitions\Equip.xlsx")

'Define the Woksheet that contains the Definition list
Set WS = WB.Worksheets("Sheet1")

'Define the Range name that defines the Definition list
Set MyDefTbl = WS.Range("MyDefs")

'Define the Document to be changed
Set myDoc = ActiveDocument

For Each MyRow In MyDefTbl.Rows
    Set MySearchRng = WS.Cells(MyRow.Row, 1)
    Set ReplacementRng = WS.Cells(MyRow.Row, 2)

    'MsgBox MySearchRng & "====>" & ReplacementRng
    myDoc.Select
    With Selection.Find
        .Text = " MERGEFIELD " & MySearchRng.Text
        .Replacement.Text = " MERGEFIELD " & ReplacementRng.Text
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With

    Selection.Find.Execute Replace:=wdReplaceAll

Next MyRow

Set MyDefTbl = Nothing
Set MyRow = Nothing

Set WS = Nothing
Set WB = Nothing
Set MyXL = Nothing
Set myDoc = Nothing
MsgBox "Complete"
End Sub



Sub MyInitializeOfficeApps()

On Error Resume Next

Set MyXL = GetObject(, "Excel.Application")

If MyXL Is Nothing Then
    Set MyXL = CreateObject("Excel.Application")
End If

On Error GoTo 0

MyXL.Visible = True

End Sub