excel - 从 MS Excel 的单元格中查找/替换 MS Word 文档
问题描述
我正在尝试使用 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
推荐阅读
- documentation - 如何为调用图中的函数设置颜色?
- c - 检查数组是否是C中的对角占优矩阵
- python-3.x - 读取包含逗号的 .csv
- r - 计算R中四个不同列的最大时间
- javascript - 即使启用了标签,Webview 标签在 Electron 中也不起作用
- pytorch - 如何应用在 fast.ai / pytorch 中开发的模型?
- java - 在 PUBSUB 中没有收到消息时通知 Websocket
- angular - Angular 反应式表单和 ngx-admin 错误 FormGroup 问题不是表单的已知属性
- php - 如何使用 PHP 从 Aws S3 下载最新文件或最近添加的文件。(Yii2)
- c# - Web API MultipartAsync 任务无结果