Question

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

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

请尝试以下示例并进行修改以适合您的要求。

   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

尝试：

.event-indicator

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

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

2 个答案: