Find/Replace MS Word Document from Cells in MS Excel

Question

I'm trying to use Excel to open a Word document. And then I want replace the text strings in Word based on what's in certain Excel cells.

E.g. MS Word contains the text, "This is a test and only a test." Excel has a sheet named "Synonyms." Cell A1 contains the text string "a test." Cell B1 contains the text "an exam." After using the text strings in Excel, the MS Word document would read, "This is an exam and only an exam."

I've been able to get the thing to perform the find/replaces in Excel (by modifying the code a bit). But I can't seem to get the thing to perform the find/replaces in Word.

Thoughts?

Here's the code I'm working with:

Option Explicit

Public Sub WordFindAndReplace()
    Dim mySheet As Worksheet, msWord As Object, itm As Range

    Set mySheet = ActiveSheet
    Dim myReplaceSheet As Worksheet
    Dim myLastRow As Long
    Dim myRow As Long
    Dim myFind As String
    Dim myReplace As String
    Set msWord = CreateObject("Word.Application")

    With msWord
        .Visible = True
        .Documents.Open "E:\Original.docm"
        .Activate

            With .ActiveDocument.Content.Find
            .ClearFormatting
            .Replacement.ClearFormatting

'   Specify name of  sheet
    Set mySheet = Sheets("Strings")

'   Specify name of Sheet with list of finds and replacements
    Set myReplaceSheet = Sheets("Synonyms")

'   Assuming the list of  that need replaced start in column B on row 1, find last entry in list
    myLastRow = myReplaceSheet.Cells(Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = False

    '   Loop through all list of replacments
    For myRow = 1 To myLastRow
'       Get find and replace values (from columns A and B)
        myFind = myReplaceSheet.Cells(myRow, "A")
        myReplace = myReplaceSheet.Cells(myRow, "B")
'       Start at top of data sheet and do replacements
        mySheet.Activate
'       Ignore errors that result from finding no matches
        On Error Resume Next
'       Do all replacements on column A of data sheet
        ColorReplacement msWord, myFind, myReplace
'       Reset error checking
        On Error GoTo 0
    Next myRow

    Application.ScreenUpdating = True

        End With

    End With

End Sub
Sub ColorReplacement(aCell As Range, findText As String, ReplaceText As String, _
                     Optional ReplaceColor As OLE_COLOR = vbRed)

    Dim p As Long

    p = InStr(1, aCell.Text, findText, vbTextCompare)
    Do While p > 0
        aCell.Characters(p, Len(findText)).Text = ReplaceText
        aCell.Characters(p, Len(ReplaceText)).Font.Color = ReplaceColor
        p = InStr(p + Len(ReplaceText), aCell.Text, findText)
    Loop

End Sub

macropod · Accepted Answer · 2019-02-27 20:58:50Z

0

Try:

Sub Demo()
Dim xlWs As Worksheet, objWrd As Object, objDoc As Object, r As Long
Set xlWs = Sheets("Synonyms")
Set objWrd = CreateObject("Word.Application")
With objWrd
  .Visible = False
  Set objDoc = .Documents.Open("E:\Original.docm", False, False, False)
  With objDoc.Content.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchCase = False
    .MatchWholeWord = False
    For r = 1 To xlWs.Cells(Rows.Count, "A").End(xlUp).Row
      .Text = xlWs.Range("A" & r).Text
      .Replacement.Text = xlWs.Range("B" & r).Text
      .Execute Replace:=2 '2 = wdReplaceAll
    Next
  End With
  objDoc.Close True
  .Quit
End With
End Sub

For testing purposes, you might want to set .Visible = True.

edited Feb 27, 2019 at 20:58

answered Feb 26, 2019 at 22:55

macropod

14k2 gold badges11 silver badges25 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

Jared Over a year ago

I went ahead and set .Visible = True. Couldn't get the code to run properly. So, I executed it line by line. And it stuck on the following line: "With .objDoc.Content.Find."

Jared Over a year ago

This is amazing! Works perfectly. Thank you, thank you! Wasn't gonna figure this out on my own.

skkakkar · Accepted Answer · 2019-02-26 17:32:58Z

0

Please try this example and modify to suit your requirements.

   Option Explicit

Public Sub WdFindAndReplace()
    Dim ws As Worksheet, msWord As Object, itm As Range

    Set ws = ActiveSheet
    Set msWord = CreateObject("Word.Application")

    With msWord
        .Visible = True
        .Documents.Open "C:\mydirb\test26.docx"  ' change as per your requirement
        .Activate

        With .ActiveDocument.Content.Find
            .ClearFormatting
            .Replacement.ClearFormatting

            For Each itm In ws.UsedRange.Columns("A").Cells

                .Text = itm.Value2                          'Find all strings in col A

                .Replacement.Text = itm.Offset(, 1).Value2  'Replacements from col B

                .MatchCase = False
                .MatchWholeWord = False

                .Execute Replace:=2     'wdReplaceAll (WdReplace Enumeration)
            Next
        End With
        .Quit SaveChanges:=True
    End With
End Sub

answered Feb 26, 2019 at 17:32

skkakkar

2,8482 gold badges20 silver badges32 bronze badges

2 Comments

Jared Over a year ago

Excellent! Thank you. Works great. Is there a way to run the program from an already open MS Word document?

skkakkar Over a year ago

@Jared Glad that it worked for you.Please accept my answer by checking the tick mark below down pointing triangle. It also did not work for me from an already open MS Word document. If I find the way to do so , I shall apprise you also.

Collectives™ on Stack Overflow

Find/Replace MS Word Document from Cells in MS Excel

2 Answers 2

2 Comments

2 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

2 Comments

2 Comments

Your Answer

Sign up or log in

Post as a guest

Related