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