Excel VBA复制文件夹报错‘对象变量或With块变量未设置’求助

问题场景 #

通过Excel标记需复制的文件夹（保留源数据不移动）：

• A列：源文件夹完整路径
• C列：拆分出的未排序文件夹名称（辅助列）
• H列：用0（不复制）或正数（需复制）标记
• I列：目标文件夹完整路径

示例：将源路径J:\work\client\department\folders\unsorted\folder 1复制到J:\work\client\department\folders\sorted\folder 1

原VBA代码运行时触发错误：Object variable or With block variable not set

错误原因 #

1. 循环内过早执行Set FSO = Nothing，导致后续循环迭代时FSO对象已销毁，无法调用GetFolder等方法
2. 未检查源/目标文件夹是否存在，路径无效时GetFolder直接抛出错误
3. 目标文件夹不存在时，CopyFolder默认不会自动创建，引发异常

修复后的VBA代码 #

Option Explicit

Private Sub folderSorting()
    Dim FSO As Object
    Dim SourcePath As String
    Dim DestPath As String
    Dim i As Integer
    
    ' 初始化FSO对象（仅执行一次）
    Set FSO = CreateObject("scripting.filesystemobject")
    i = 2
    
    ' 遍历数据行，直到A列为空
    Do Until Cells(i, 1).Value = ""
        SourcePath = Trim(Cells(i, 1).Value)
        DestPath = Trim(Cells(i, 9).Value)
        
        ' 重置J列状态
        Cells(i, 10).Value = ""
        
        ' 检查源文件夹是否存在
        If Not FSO.FolderExists(SourcePath) Then
            Cells(i, 10).Value = "源文件夹不存在"
            i = i + 1
            GoTo NextRow
        End If
        
        ' 检查目标文件夹，不存在则创建
        If Not FSO.FolderExists(DestPath) Then
            On Error Resume Next
            FSO.CreateFolder DestPath
            If Err.Number <> 0 Then
                Cells(i, 10).Value = "目标文件夹创建失败：" & Err.Description
                i = i + 1
                Err.Clear
                GoTo NextRow
            End If
            On Error GoTo 0
        End If
        
        ' 检查是否需要复制（H列为正数）
        If IsNumeric(Cells(i, 8).Value) And Cells(i, 8).Value > 0 Then
            On Error Resume Next
            ' 复制文件夹（覆盖已存在的目标文件夹）
            FSO.CopyFolder Source:=SourcePath, Destination:=DestPath, OverWriteFiles:=True
            If Err.Number = 0 Then
                Cells(i, 10).Value = "已复制到目标路径"
            Else
                Cells(i, 10).Value = "复制失败：" & Err.Description
                Err.Clear
            End If
            On Error GoTo 0
        Else
            Cells(i, 10).Value = "无需复制"
        End If
        
NextRow:
        i = i + 1
    Loop
    
    ' 循环结束后清理对象
    Set FSO = Nothing
    MsgBox "文件夹复制任务已完成", vbInformation
End Sub

关键优化点 #

• 将FSO对象的初始化和清理移到循环外，避免重复创建/销毁
• 增加源文件夹存在性检查，避免无效路径报错
• 自动创建不存在的目标文件夹，减少手动操作
• 增加错误捕获，单个行出错不终止整个程序，同时在J列标记错误原因
• 严格判断H列标记值，确保仅正数触发复制
• 增加OverWriteFiles:=True参数，允许覆盖已存在的目标文件夹（可根据需求调整）

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