修改文件夹级查找替换VBA宏以支持子文件夹及路径直接输入

下面是修改后的完整VBA代码，直接复制到你的Word模块里就能用，关键修改点都加了注释，方便你调整：

Sub BatchFindReplaceRTF()
    Dim fso As Object
    Dim parentFolder As Object
    Dim targetPath As String
    Dim doc As Object ' Word.Document
    Dim findText As String
    Dim replaceText As String
    
    ' --------------------------
    ' 路径设置：二选一即可
    ' 方式1：硬编码父文件夹路径（直接写死，不用弹窗）
    ' targetPath = "C:\你的父文件夹完整路径"
    ' 方式2：弹出输入框手动输入路径
    targetPath = InputBox("请输入父文件夹路径：", "路径输入", "C:\默认路径示例")
    ' --------------------------
    
    ' 检查路径是否存在
    If Dir(targetPath, vbDirectory) = "" Then
        MsgBox "输入的路径不存在，请检查后重试！", vbExclamation
        Exit Sub
    End If
    
    ' 设置查找替换内容
    findText = InputBox("请输入要查找的文本：", "查找内容")
    replaceText = InputBox("请输入要替换的文本：", "替换内容")
    
    If findText = "" Or replaceText = "" Then
        MsgBox "查找或替换内容不能为空！", vbExclamation
        Exit Sub
    End If
    
    ' 创建文件系统对象（后期绑定，无需手动添加引用）
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set parentFolder = fso.GetFolder(targetPath)
    
    ' 递归遍历所有文件夹和RTF文件
    ProcessFolder parentFolder, findText, replaceText
    
    MsgBox "批量替换完成！", vbInformation
End Sub

Private Sub ProcessFolder(folder As Object, findText As String, replaceText As String)
    Dim file As Object
    Dim subFolder As Object
    Dim doc As Object
    
    ' 处理当前文件夹下的RTF文件
    For Each file In folder.Files
        If LCase(fso.GetExtensionName(file.Path)) = "rtf" Then
            On Error Resume Next ' 捕获文件打开失败的错误
            Set doc = CreateObject("Word.Application").Documents.Open(file.Path, ReadOnly:=False)
            If Err.Number <> 0 Then
                MsgBox "无法打开文件：" & file.Path & vbCrLf & "错误原因：" & Err.Description, vbCritical
                Err.Clear
                GoTo NextFile
            End If
            On Error GoTo 0
            
            ' 执行全局查找替换
            With doc.Content.Find
                .Text = findText
                .Replacement.Text = replaceText
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=wdReplaceAll
            End With
            
            ' 保存并关闭文件
            doc.Save
            doc.Close
            Set doc = Nothing
NextFile:
        End If
    Next file
    
    ' 递归处理子文件夹
    For Each subFolder In folder.SubFolders
        ProcessFolder subFolder, findText, replaceText
    Next subFolder
End Sub

关键修改说明 #

1. 子文件夹遍历功能：

   • 新增ProcessFolder私有子过程，用递归逻辑自动遍历当前文件夹及所有嵌套子文件夹
   • 通过FileSystemObject的SubFolders集合获取子文件夹，循环调用自身完成全目录扫描

2. 自定义路径设置：

   • 代码开头提供两种路径选择：
     • 硬编码：把targetPath直接赋值为你的父文件夹路径（比如"D:\我的RTF文件库"），注释掉输入框那行即可
     • 输入框：保留targetPath = InputBox(...)，运行时会弹出输入框让你手动输入路径
   • 增加了路径有效性检查，避免输入错误路径导致程序崩溃

使用注意事项 #

• 运行前关闭所有已打开的RTF文件，避免文件锁定无法修改
• 处理5000个文件需要一定时间，运行期间不要中断程序
• 遇到损坏或无权限的文件，程序会弹出提示并跳过，不影响整体任务

内容的提问来源于stack exchange，提问作者Michael