Найти / заменить документ MS Word с ячеек в MS Excel

Question

Я пытаюсь использовать Excel, чтобы открыть документ Word.И затем я хочу заменить текстовые строки в Word на основе содержимого определенных ячеек Excel.

Например, MS Word содержит текст: «Это тест, а только тест».В Excel есть лист с названием «Синонимы».Ячейка А1 содержит текстовую строку «тест».Ячейка 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