[英]Find/Replace MS Word Document from Cells in MS Excel
我正在尝试使用 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
请尝试此示例并进行修改以满足您的要求。
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
尝试:
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。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.