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

Question

我正在尝试使用Excel打开Word文档。然后我想根据某些Excel单元格中的内容替换Word中的文本字符串。

例如。 MS Word包含文本，“这是一个测试，只是一个测试。” Excel有一个名为“Synonyms”的工作表。单元格A1包含文本字符串“a test”。单元格B1包含文本“考试”。在Excel中使用文本字符串后，MS Word文档将显示“这是一个考试，只有一个考试”。

我已经能够在Excel中执行查找/替换（通过稍微修改代码）。但我似乎无法在Word中执行查找/替换。

思考？

这是我正在使用的代码：

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

尝试：

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

出于测试目的，您可能希望设置.Visible = True。

Answer 2

请尝试此示例并进行修改以满足您的要求。

   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