在多个office文档内替换关键字

想在多个excel中，进行关键字替换。涉及到批量操作，就想到了用宏，没有考虑用其他脚本做开发。
直接的思路就是遍历目录，遍历打开文档，再执行替换。过程中涉及一些文档状态，例如只读呀、禁用url更新之类的，就得手动确认一下了。

• 针对excel：

Sub BatchReplaceFiles()
    Dim folderPath As String
    Dim searchText As String
    Dim replaceText As String
    
    ' 带一点点交互，用户输入参数
    searchText = InputBox("请输入要查找的文本：", "查找内容", "旧文本")
    replaceText = InputBox("请输入要替换的文本：", "替换内容", "新文本")
    folderPath = InputBox("请输入根目录路径（如：C:\替换文件存放路径）：", "文件夹路径")
    
    ' 开始处理
    ProcessFolder folderPath, searchText, replaceText
    MsgBox "批量替换完成！"
End Sub

Private Sub ProcessFolder(ByVal folderPath As String, ByVal searchText As String, ByVal replaceText As String)
    Dim fso As Object
    Dim folder As Object
    Dim subfolder As Object
    Dim file As Object
    
    ' 初始化文件系统对象
    On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error GoTo 0
    
    ' 获取根文件夹对象
    Set folder = fso.GetFolder(folderPath)
    
    ' 处理当前文件夹内的所有Excel文件
    For Each file In folder.Files
        ' 过滤.xls和.xlsx文件
        If LCase(fso.GetExtensionName(file.Name)) = "xls" Or _
           LCase(fso.GetExtensionName(file.Name)) = "xlsx" Then
            ReplaceInWorkbook file.Path, searchText, replaceText
        End If
    Next file

    ' 递归处理子文件夹
    For Each subfolder In folder.SubFolders
        ProcessFolder subfolder.Path, searchText, replaceText
    Next subfolder
End Sub

Private Sub ReplaceInWorkbook(ByVal filePath As String, ByVal searchText As String, ByVal replaceText As String)
    Dim wb As Workbook
    On Error Resume Next
    ' 禁用屏幕刷新提高速度
    Application.ScreenUpdating = False
    
    ' 尝试打开工作簿
    Set wb = Workbooks.Open(filePath)
    If wb Is Nothing Then
        Debug.Print "⚠️ 文件未打开：" & filePath
        Exit Sub
    End If
    
    ' 遍历所有工作表执行替换
    For Each ws In wb.Sheets
        ws.Cells.Replace What:=searchText, Replacement:=replaceText, _
            LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
            SearchFormat:=False, ReplaceFormat:=False
    Next ws
    
    ' 保存并关闭工作簿
    wb.Close SaveChanges:=True
    Set wb = Nothing
    
    Application.ScreenUpdating = True
    On Error GoTo 0
End Sub

• 针对word：

Sub BatchReplaceWordFiles()
    Dim folderPath As String
    Dim searchText As String
    Dim replaceText As String
    
    ' 输入参数
    searchText = InputBox("请输入要查找的文本：", "查找内容", "旧文本")
    replaceText = InputBox("请输入要替换的文本：", "替换内容", "新文本")
    folderPath = InputBox("请输入根目录路径（如：C:\替换文件存放路径）：", "文件夹路径")
    
    ' 开始处理
    ProcessWordFiles folderPath, searchText, replaceText
    MsgBox "Word文件批量替换完成！"
End Sub

Private Sub ProcessWordFiles(ByVal folderPath As String, ByVal searchText As String, ByVal replaceText As String)
    Dim fso As Object
    Dim folder As Object
    Dim subfolder As Object
    Dim file As Object
    
    ' 初始化文件系统对象
    On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error GoTo 0
    
    ' 获取根文件夹对象
    Set folder = fso.GetFolder(folderPath)
    
    ' 处理当前文件夹内的Word文件
    For Each file In folder.Files
        ' 过滤.doc和.docx文件
        If LCase(fso.GetExtensionName(file.Name)) = "doc" Or _
           LCase(fso.GetExtensionName(file.Name)) = "docx" Then
            ReplaceInWordDocument file.Path, searchText, replaceText
        End If
    Next file

    ' 递归处理子文件夹
    For Each subfolder In folder.SubFolders
        ProcessWordFiles subfolder.Path, searchText, replaceText
    Next subfolder
End Sub

Private Sub ReplaceInWordDocument(ByVal filePath As String, ByVal searchText As String, ByVal replaceText As String)
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim searchRange As Object
    
    On Error Resume Next
    
    ' 创建Word应用程序对象
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False  ' 后台运行不显示界面
    
    ' 打开文档
    Set wordDoc = wordApp.Documents.Open(filePath)
    If wordDoc Is Nothing Then
        Debug.Print "⚠️ 文件未打开：" & filePath
        Exit Sub
    End If
    
    ' 执行替换操作（全篇范围替换）
    With wordDoc.Content.Find
        .Text = searchText
        .Replacement.Text = replaceText
        .Forward = True
        .Wrap = 1 ' wdFindContinue
        .Execute Replace:=2 ' wdReplaceAll
    End With
    
    ' 保存并关闭文档
    wordDoc.Close SaveChanges:=True
    Set wordDoc = Nothing
    
    ' 关闭Word应用（避免残留进程）
    wordApp.Quit
    Set wordApp = Nothing
    
    On Error GoTo 0
End Sub

---

如果要处理多个关键字，就先再替换字符串上做做文章。比如用标识符做拆分，然后多次执行替换。