从 MS Excel 中的单元格中查找/替换 MS Word 文档

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.

Eg 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

Answer 1

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

Answer 2

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.