请求修改VBA代码：实现父文件夹下批量按扩展名整理文件

以下是修改后的代码，支持选择父文件夹后自动遍历所有层级子文件夹，按文件扩展名分类整理，并保留原代码的核心逻辑（整理后创建对应归档文件夹、移除原空文件夹）：

Option Explicit

Sub OrganizeAllSubfoldersByFileType()
    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
    
    Dim parentFolderPath As String
    Dim foldPicker As FileDialog
    Set foldPicker = Application.FileDialog(msoFileDialogFolderPicker)
    
    With foldPicker
        .Title = "选择父文件夹（将遍历所有子文件夹）"
        If .Show = -1 Then parentFolderPath = .SelectedItems(1)
    End With
    
    If parentFolderPath <> "" Then
        ' 递归遍历父文件夹下所有子文件夹并执行整理
        TraverseAndOrganizeFolders fso.GetFolder(parentFolderPath), fso
    End If
    
    Set fso = Nothing
    Set foldPicker = Nothing
    MsgBox "文件整理完成！"
End Sub

' 递归遍历所有子文件夹
Private Sub TraverseAndOrganizeFolders(targetFolder As Scripting.Folder, fso As Scripting.FileSystemObject)
    Dim subFolder As Scripting.Folder
    
    ' 处理当前文件夹
    ProcessSingleFolder targetFolder, fso
    
    ' 递归处理嵌套子文件夹
    For Each subFolder In targetFolder.SubFolders
        TraverseAndOrganizeFolders subFolder, fso
    Next subFolder
End Sub

' 单个文件夹的文件整理逻辑
Private Sub ProcessSingleFolder(sourceFolder As Scripting.Folder, fso As Scripting.FileSystemObject)
    Dim organizedFolderPath As String
    Dim fle As Scripting.File
    Dim fileExt As String
    
    ' 创建归档文件夹路径
    organizedFolderPath = sourceFolder.Path & " - Organized\"
    
    ' 归档文件夹不存在则创建
    If Not fso.FolderExists(organizedFolderPath) Then
        fso.CreateFolder organizedFolderPath
    End If
    
    ' 遍历所有文件并按扩展名分类
    For Each fle In sourceFolder.Files
        ' 获取带点的扩展名（如".docx"）
        fileExt = "." & fso.GetExtensionName(fle.Name)
        
        ' 扩展名分类文件夹不存在则创建
        If Not fso.FolderExists(organizedFolderPath & fileExt) Then
            fso.CreateFolder organizedFolderPath & fileExt
        End If
        
        ' 移动文件到对应分类文件夹
        fle.Move organizedFolderPath & fileExt & "\" & fle.Name
    Next fle
    
    ' 仅当原文件夹为空时删除，避免报错
    If sourceFolder.Files.Count = 0 And sourceFolder.SubFolders.Count = 0 Then
        sourceFolder.Delete
    End If
End Sub

核心改动说明 #

• 递归遍历子文件夹：新增TraverseAndOrganizeFolders过程，自动遍历父文件夹下所有层级的子文件夹，无需手动逐个选择。
• 改用扩展名分类：替换原代码中依赖系统语言的Fle.Type（如"Microsoft Word 文档"）为文件扩展名，分类更准确且不受语言环境影响。
• 优化文件操作：将原代码的「复制+删除原文件夹」改为直接Move操作，提升效率并节省磁盘空间。
• 安全删除原文件夹：仅在原文件夹为空（文件已全部移走、无嵌套子文件夹）时才删除，避免因残留内容导致的删除失败。

前置准备 #

运行前需确保VBA工程已引用Microsoft Scripting Runtime：

1. 打开VBA编辑器（Alt+F11）；
2. 点击「工具」→「引用」；
3. 勾选Microsoft Scripting Runtime并确定。

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