EXCEL VBA将word里面的指定的关键词替换掉后并标记红色字体

在这里插入图片描述


Sub 开关()
Call 新建副本
Call ReplaceAndHighlightInFolder
End Sub
Sub 新建副本()fpath = ThisWorkbook.Path & "\"Dim MyFile As ObjectSet MyFile = CreateObject("Scripting.FileSystemObject")MyFile.CopyFolder fpath & "\待处理文档", ThisWorkbook.Path & "\处理后的标红的文档"Set MyFile = Nothing
End SubSub ReplaceAndHighlightInFolder()
t = Time()Dim folderPath As StringDim excelApp As ObjectDim excelWorkbook As ObjectDim sheet As ObjectDim rng As ObjectDim findText As StringDim replaceText As Stringfpath = ThisWorkbook.Path & "\"Set sheet = ThisWorkbook.Worksheets(1)folderPath = fpath & "处理后的标红的文档\"' 遍历Excel表格，进行替换和标红' 遍历文件夹中的所有文档Dim objFSO As ObjectDim objFolder As ObjectDim objFile As ObjectSet objFSO = CreateObject("Scripting.FileSystemObject")Set objFolder = objFSO.GetFolder(folderPath)Dim wordApp As ObjectDim wordDoc As Object' 打开Word应用Set wordApp = CreateObject("Word.Application")wordApp.Visible = TrueFor Each objFile In objFolder.FilesIf objFSO.GetExtensionName(objFile.Name) = "docx" Or objFSO.GetExtensionName(objFile.Name) = "doc" Then ' 只处理docx文件' 打开Word文档Set doc = wordApp.Documents.Open(objFile.Path)For Each rng In sheet.Range("A1:A" & sheet.Cells(sheet.Rows.Count, "A").End(-4162).Row)replaceWord = rng.ValuereplaceWith = rng.Offset(0, 1).Value' 遍历文档中的每个段落，进行替换和标红' 获取当前活动的文档' 从文档的开头开始查找需要替换的词Set findRange = doc.Range' 开始查找并替换With findRange.Find.Text = replaceWord.MatchCase = True.MatchWholeWord = TrueDo While .ExecuteIf findRange.Text = replaceWord ThenfindRange.Text = replaceWithfindRange.Font.Color = RGB(255, 0, 0)End IffindRange.Collapse Direction:=wdCollapseEndLoopEnd WithNext' 保存并关闭Word文档doc.Savedoc.Close' 释放Word对象Set doc = NothingEnd IfNext objFilewordApp.QuitMsgBox "替换完成，耗时" & DateDiff("s", t, Time()) & "秒"
End Sub