递归搜索并移动指定文件的VBA代码运行报错求助

原代码存在的问题 #

• 列匹配错误：需求明确读取A列文件名，但代码错误读取了C列数据（lastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row及循环范围C3:C" & lastRow）
• 文件路径错误：递归函数仅返回文件是否存在，未记录实际存储路径，后续移动时直接用源根路径拼接文件名，导致子文件夹中的文件无法被正确定位
• 递归变量冲突：递归函数中用objFolder同时指代父文件夹和子文件夹，遍历子文件夹时会覆盖变量，引发递归逻辑异常
• 路径拼接不严谨：手动添加\可能导致路径重复（如用户选择的文件夹本身已带\），引发路径格式错误
• 错误屏蔽过度：全局On Error Resume Next会掩盖所有错误，无法排查问题根源
• 未处理目标文件重名：移动时若目标文件夹已有同名文件，会直接报错中断流程

修复后的完整代码 #

Sub MoveSelectedFilesRecursive()
    Dim sourceFolderDialog As FileDialog
    Dim destinationFolderDialog As FileDialog
    Dim sourceFolderPath As String
    Dim destinationFolderPath As String
    Dim FSO As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim c As Range
    Dim foundFilePath As String
    
    ' 选择源父文件夹
    Set sourceFolderDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With sourceFolderDialog
        .Title = "选择源父文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        sourceFolderPath = .SelectedItems(1)
    End With
    
    ' 选择目标文件夹
    Set destinationFolderDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With destinationFolderDialog
        .Title = "选择目标文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        destinationFolderPath = .SelectedItems(1)
    End With
    
    ' 初始化FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
    ' 自动处理路径末尾分隔符，避免格式错误
    sourceFolderPath = FSO.BuildPath(sourceFolderPath, "")
    destinationFolderPath = FSO.BuildPath(destinationFolderPath, "")
    
    ' 设置工作表（可根据实际修改表名）
    Set ws = ThisWorkbook.Sheets("Sheet1")
    ' 获取A列最后一行数据行号
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 遍历A列的文件名（起始行A3可根据实际调整）
    For Each c In ws.Range("A3:A" & lastRow)
        foundFilePath = ""
        ' 递归查找文件并返回完整路径
        foundFilePath = FindFileRecursive(sourceFolderPath, c.Value, FSO)
        
        If foundFilePath <> "" Then
            On Error Resume Next ' 仅在移动时捕获重名错误
            ' 移动文件，若目标已存在则覆盖（可修改为跳过逻辑）
            FSO.MoveFile foundFilePath, destinationFolderPath & c.Value
            If Err.Number = 0 Then
                c.Offset(0, 1).Value = "已移动"
            Else
                c.Offset(0, 1).Value = "移动失败：文件已存在"
                Err.Clear
            End If
            On Error GoTo 0 ' 恢复正常错误处理
        Else
            c.Offset(0, 1).Value = "未找到"
        End If
    Next c
    
    ' 清理对象
    Set FSO = Nothing
    MsgBox "处理完成"
End Sub

' 递归查找文件并返回完整路径，未找到则返回空字符串
Function FindFileRecursive(ByVal folderPath As String, ByVal fileName As String, ByVal FSO As Object) As String
    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim objFile As Object
    
    Set objFolder = FSO.GetFolder(folderPath)
    
    ' 检查当前文件夹内的文件
    For Each objFile In objFolder.Files
        If objFile.Name = fileName Then
            FindFileRecursive = objFile.Path
            Exit Function
        End If
    Next objFile
    
    ' 递归检查子文件夹
    For Each objSubFolder In objFolder.SubFolders
        FindFileRecursive = FindFileRecursive(objSubFolder.Path, fileName, FSO)
        If FindFileRecursive <> "" Then Exit Function
    Next objSubFolder
    
    ' 未找到文件，返回空字符串
    FindFileRecursive = ""
End Function

修复说明 #

• 修正列读取逻辑：将读取列改为A列，匹配需求中的文件名存储位置
• 返回文件实际路径：修改递归函数为返回文件完整路径，解决移动时的路径定位错误
• 避免变量冲突：递归函数中用objSubFolder指代子文件夹，避免覆盖父文件夹变量导致的逻辑异常
• 规范路径处理：使用FSO.BuildPath自动处理路径分隔符，避免手动拼接的格式错误
• 优化错误处理：仅在移动文件时临时屏蔽重名错误，其余部分保留正常错误提示，便于排查问题
• 处理重名场景：捕获移动时的重名错误，在B列标注具体状态，可根据需求修改为覆盖或跳过逻辑

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