使用VBA批量重命名多层子文件夹文件并导出至指定目录

问题背景 #

主文件夹C:\DESKTOP\EMPLOYEES下包含多个顶层子文件夹（命名格式如JOHN_DOE_12345），这些顶层文件夹内存在多层嵌套子文件夹，目标文件存储在深层目录中。需要实现：

1. 提取顶层子文件夹名称的后缀部分（如12345）作为文件名前缀
2. 将所有深层子文件夹内的文件重命名后批量复制到新目录
   原VBA代码仅支持单层子文件夹遍历，无法处理多层嵌套结构，需修改代码实现递归遍历。

注意事项 #

• 仅复制重命名后的文件到目标目录，不修改源文件
• 确认代码测试正常后，再将代码中的.Copy替换为.Move
• 需根据实际需求调整代码中的工作表名称Sheet1及目标路径所在单元格A8

修改后的VBA代码 #

Sub CopyFilesWithRecursion()
    ' 需添加引用：工具->引用->Microsoft Scripting Runtime
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' 根据实际调整工作表名称
    
    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
   
    ' 获取源文件夹路径
    Dim sFolderPath As String: sFolderPath = CStr(ws.Range("A7").Value)
    If Not fso.FolderExists(sFolderPath) Then
        MsgBox "源文件夹 """ & sFolderPath & """ 不存在。", vbCritical
        Exit Sub
    End If
    
    ' 获取目标文件夹路径
    Dim dFolderPath As String: dFolderPath = CStr(ws.Range("A8").Value) ' 根据实际调整单元格位置
    If Not fso.FolderExists(dFolderPath) Then
        MsgBox "目标文件夹 """ & dFolderPath & """ 不存在。", vbCritical
        Exit Sub
    End If
    
    Dim sSubfolder As Folder
    Dim sDelimiterPosition As Long
    Dim ssName As String
    Dim dPrefix As String
    
    ' 遍历所有顶层子文件夹
    For Each sSubfolder In fso.GetFolder(sFolderPath).SubFolders
        ssName = sSubfolder.Name
        sDelimiterPosition = InStrRev(ssName, "_")
        If sDelimiterPosition > 0 Then
            dPrefix = Right(ssName, Len(ssName) - sDelimiterPosition)
            ' 递归处理当前顶层文件夹下的所有嵌套子文件夹和文件
            ProcessNestedFolders sSubfolder, dPrefix, dFolderPath, fso
        End If
    Next sSubfolder
    
    MsgBox "文件处理完成！", vbInformation
End Sub

' 递归函数：遍历嵌套子文件夹并处理文件
Private Sub ProcessNestedFolders(currentFolder As Folder, prefix As String, destPath As String, fso As Scripting.FileSystemObject)
    Dim sFile As File
    Dim dFilePath As String
    
    ' 处理当前文件夹下的所有文件
    For Each sFile In currentFolder.Files
        dFilePath = fso.BuildPath(destPath, prefix & "_" & sFile.Name)
        sFile.Copy Destination:=dFilePath ' 测试正常后可替换为.Move
    Next sFile
    
    ' 递归处理当前文件夹下的子文件夹
    Dim subFolder As Folder
    For Each subFolder In currentFolder.SubFolders
        ProcessNestedFolders subFolder, prefix, destPath, fso
    Next subFolder
End Sub

代码修改说明 #

1. 新增ProcessNestedFolders递归函数，实现对所有层级嵌套子文件夹的遍历
2. 保留原有的顶层子文件夹后缀提取逻辑，确保所有深层文件都能获取到对应的前缀
3. 增加处理完成提示，方便确认执行状态
4. 优化了变量命名和提示信息的可读性

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