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

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

Sub 开关()
Call 新建副本
Call ReplaceAndHighlightInFolder
End Sub
Sub 新建副本()
    fpath = ThisWorkbook.Path & "\"
    Dim MyFile As Object
    Set MyFile = CreateObject("Scripting.FileSystemObject")
    MyFile.CopyFolder fpath & "\待处理文档", ThisWorkbook.Path & "\处理后的标红的文档"
    Set MyFile = Nothing
End Sub


Sub ReplaceAndHighlightInFolder()
t = Time()
    Dim folderPath As String
    Dim excelApp As Object
    Dim excelWorkbook As Object
    Dim sheet As Object
    Dim rng As Object
    Dim findText As String
    Dim replaceText As String
    
    fpath = ThisWorkbook.Path & "\"
    
    Set sheet = ThisWorkbook.Worksheets(1)
    
    folderPath = fpath & "处理后的标红的文档\"

    
    ' 遍历Excel表格，进行替换和标红

                ' 遍历文件夹中的所有文档
        Dim objFSO As Object
        Dim objFolder As Object
        Dim objFile As Object
        
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objFolder = objFSO.GetFolder(folderPath)
        Dim wordApp As Object
        Dim wordDoc As Object
        
        ' 打开Word应用
        Set wordApp = CreateObject("Word.Application")
        wordApp.Visible = True
        For Each objFile In objFolder.Files
            If 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.Value
                    replaceWith = rng.Offset(0, 1).Value
 
                ' 遍历文档中的每个段落，进行替换和标红

                
                ' 获取当前活动的文档
                
                ' 从文档的开头开始查找需要替换的词
                   Set findRange = doc.Range
    
                    ' 开始查找并替换
                    With findRange.Find
                        .Text = replaceWord
                        .MatchCase = True
                        .MatchWholeWord = True
                        Do While .Execute
                            If findRange.Text = replaceWord Then
                                findRange.Text = replaceWith
                                findRange.Font.Color = RGB(255, 0, 0)
                            End If
                            findRange.Collapse Direction:=wdCollapseEnd
                        Loop
                    End With
                Next
                                
                
                
                
                ' 保存并关闭Word文档
                doc.Save
                doc.Close
                
                ' 释放Word对象
                Set doc = Nothing
                
            End If
        Next objFile
    
    wordApp.Quit
    
    
    MsgBox "替换完成，耗时" & DateDiff("s", t, Time()) & "秒"
End Sub