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

Question

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

例如MS Word 包含文本“这是一个测试，只是一个测试”。 Excel 有一个名为“同义词”的工作表。单元格 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