如何移动存在多个异常的文件夹？VBA移动文件夹代码运行失败如何解决

原有代码的2个核心问题 #

• Scripting.FileSystemObject的MoveFolder方法不支持多层通配符路径，你定义的src_path包含两层*通配符，属于方法不兼容的入参，调用必然触发运行时错误。
• 连续使用On Error Resume Next直接吞噬了所有错误提示，无法定位具体报错原因；你尝试加波浪号删除异常的操作完全无效，VBA语法中波浪号没有注释或屏蔽错误的作用，反而可能额外引入语法错误。

修复方案 #

需要先实现通配符路径的遍历匹配，再逐一对匹配到的文件夹执行移动操作，修正后的代码如下：

Sub PAUL_COMPLETE()
    Dim fso As Object
    Dim user_folder As Object
    Dim sub_folder As Object
    Dim src_root As String
    Dim dest_path As String
    Dim completed_path As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    src_root = ActiveWorkbook.Path & "\USERS\"
    dest_path = ActiveWorkbook.Path & "\READY TO BILL\DEPARTMENT REVIEW\"
    
    ' 先判断根目录是否存在，避免路径错误
    If Not fso.FolderExists(src_root) Or Not fso.FolderExists(dest_path) Then
        MsgBox "源根目录或目标目录不存在，请检查路径", vbCritical
        Exit Sub
    End If
    
    ' 遍历USERS下的所有子文件夹，匹配*\COMPLETED\*结构
    For Each user_folder In fso.GetFolder(src_root).SubFolders
        completed_path = user_folder.Path & "\COMPLETED\"
        If fso.FolderExists(completed_path) Then
            For Each sub_folder In fso.GetFolder(completed_path).SubFolders
                ' 移动前先判断目标路径是否已存在同名文件夹，避免冲突
                If Not fso.FolderExists(dest_path & sub_folder.Name) Then
                    fso.MoveFolder sub_folder.Path, dest_path & sub_folder.Name
                Else
                    ' 可以根据需求调整冲突处理逻辑，比如重命名后移动
                    MsgBox "目标路径已存在文件夹：" & sub_folder.Name & "，跳过移动", vbExclamation
                End If
            Next
        End If
    Next
    
    ' 释放对象
    Set sub_folder = Nothing
    Set user_folder = Nothing
    Set fso = Nothing
End Sub

注意事项 #

• 运行代码前请先备份目标文件夹和源文件夹内的文件，避免误操作导致数据丢失
• 如果需要移动COMPLETED下的文件而非子文件夹，将代码中遍历SubFolders的部分改为遍历Files，调用MoveFile方法即可

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