VBA文件夹遍历循环异常：仅处理首个文件后终止求助

我帮你排查了代码里的问题，发现两个核心原因导致第一个WHILE循环只处理完首个文件就终止，第二个符合条件的xwalks.xlsx没被处理：

问题诊断 #

1. 强制终止的记录集循环：在处理LoopThroughFile=-1的配置时，你在Do Until Rs1.EOF循环里加了Exit Do语句，这会导致不管当前有多少条配置规则，只处理第一条就跳出记录集循环。更糟的是，代码里还多了一个无效的End If，直接打乱了语法逻辑，让程序的循环流程提前中断。
2. Dir函数的缓存冲突：你在处理单个文件时，立刻执行了Kill删除网络路径的文件，但Dir函数是基于初始遍历的目录缓存工作的——一旦缓存里的文件被删除，后续的CurLoadFile = Dir就无法正确获取下一个文件了。

修复后的完整代码 #

我把问题点全部修正，同时优化了对象管理、逻辑结构，确保所有符合条件的文件都能被遍历处理：

Public Function RunLoadFilesTest()
    Application.SetOption "Confirm Action Queries", False
    Application.SetOption "Confirm Record Changes", False
    Application.SetOption "Confirm Document Deletions", False
    
    Dim MyObj As Object, MySource As Object
    Dim Rs1 As DAO.Recordset
    Dim VExcelFileName As String, VRenameTo As String, VLoadXLSMFileName As String, NewFileName As String, CurFileName As String
    Dim CurLoadFile As Variant
    Dim VLoadCategoryID As Long, VLoopThroughFile As Long
    Dim MainProjectName As String, UFProjectName As String ' 注意：需确保调用前已赋值
    Dim RunDate As Date, StartRunTime As Date
    Dim ProjectPath As String, FormattedDate As String, ProjectMonthlyPath As String, ProjectNetworkLoadPath As String, ProjectLocalLoadPath As String, ProjectPreviousPath As String
    Dim ReportYear As Long, ReportQuarter As Long
    Dim ExcelApp As Object ' 补充Excel对象声明，避免未定义错误
    
    ' 初始化日期与路径（修正原代码重复赋值问题）
    RunDate = Format(DateAdd("q", 1, DateAdd("m", -2, DateSerial(Year(Date), (DatePart("q", Date) * 3) - 3, 1))) - 1, "dd-mmm-yyyy")
    ReportYear = Year(RunDate)
    ReportQuarter = DatePart("q", RunDate)
    FormattedDate = ReportYear & "-Q" & ReportQuarter
    
    ' 路径赋值（需确保MainProjectName、CurPath、CurProjectID已正确初始化）
    ProjectPath = "\\dddd\AutomationResults\" & MainProjectName & "\"
    ProjectMonthlyPath = ProjectPath & FormattedDate & "\"
    ProjectNetworkLoadPath = ProjectPath & "_Load\"
    ProjectLocalLoadPath = CurPath & "_Load\"
    ProjectPreviousPath = ProjectPath & "_Previous\"
    
    ' 清空本地加载目录
    If Len(Dir$(ProjectLocalLoadPath & "*.*")) > 0 Then
        Kill ProjectLocalLoadPath & "*.*"
    End If
    
    ' 处理LoopThroughFile=-1：每个符合条件的文件处理后立即执行对应逻辑
    If DCount("LoadFileID", "AP_LoadFiles", "LoopThroughFile=-1 And ProjectID=" & CurProjectID) > 0 Then
        ' 预存所有文件到集合，避免Dir缓存被文件删除影响
        Dim fileList As Collection
        Set fileList = New Collection
        CurLoadFile = Dir(ProjectNetworkLoadPath)
        While CurLoadFile <> ""
            fileList.Add CurLoadFile
            CurLoadFile = Dir
        Wend
        
        ' 遍历预存的文件列表
        For Each CurLoadFile In fileList
            CurFileName = CurLoadFile
            Set Rs1 = CurrentDb.OpenRecordset("SELECT * FROM AP_LoadFiles WHERE LoopThroughFile=-1 And ProjectID=" & CurProjectID & " Order by LoadFileID Desc")
            
            Do Until Rs1.EOF
                VLoadCategoryID = Rs1("LoadCategoryID")
                VLoopThroughFile = Rs1("LoopThroughFile")
                
                ' 确定重命名后的文件名
                If Not IsNull(Rs1("RenameTo")) And Rs1("RenameTo") <> "" Then
                    NewFileName = Rs1("RenameTo")
                Else
                    NewFileName = CurFileName
                End If
                
                ' 判断当前文件是否符合配置规则
                If (VLoadCategoryID = 2 And CurFileName Like "*" & Rs1("ExcelFileName") & "*") Or _
                   (VLoadCategoryID = 3 And CurFileName = Rs1("ExcelFileName")) Or _
                   VLoadCategoryID = 1 Then
                    ' 复制到本地加载目录
                    FileCopy ProjectNetworkLoadPath & CurFileName, ProjectLocalLoadPath & NewFileName
                    
                    ' 执行指定的XLSM文件（优化对象释放，避免残留Excel进程）
                    If Not IsNull(Rs1("LoadXLSMFileName")) And Rs1("LoadXLSMFileName") <> "" Then
                        Set ExcelApp = CreateObject("Excel.Application")
                        ExcelApp.Workbooks.Open CurPath & Rs1("LoadXLSMFileName") & ".xlsm", True
                        ExcelApp.Visible = False
                        ExcelApp.Quit
                        Set ExcelApp = Nothing
                    End If
                    
                    ' 复制到历史存档目录
                    FileCopy ProjectNetworkLoadPath & CurFileName, ProjectPreviousPath & FormattedDate & "_" & CurFileName
                End If
                
                Rs1.MoveNext
            Loop
            
            Rs1.Close
            Set Rs1 = Nothing
            
            ' 所有配置规则处理完后，再删除网络路径的文件
            If Len(Dir$(ProjectNetworkLoadPath & CurFileName)) > 0 Then
                Kill ProjectNetworkLoadPath & CurFileName
            End If
            
            ' 清理本地临时文件
            If Len(Dir$(ProjectLocalLoadPath & CurFileName)) > 0 Then
                Kill ProjectLocalLoadPath & CurFileName
            End If
            
            Debug.Print "已处理文件: " & CurFileName
        Next CurLoadFile
    End If
    
    ' 处理LoopThroughFile=0：所有文件处理完成后统一执行一次逻辑
    If DCount("LoadFileID", "AP_LoadFiles", "LoopThroughFile=0 And ProjectID=" & CurProjectID) > 0 Then
        Dim fileList0 As Collection
        Set fileList0 = New Collection
        CurLoadFile = Dir(ProjectNetworkLoadPath)
        While CurLoadFile <> ""
            fileList0.Add CurLoadFile
            CurLoadFile = Dir
        Wend
        
        For Each CurLoadFile In fileList0
            CurFileName = CurLoadFile
            Set Rs1 = CurrentDb.OpenRecordset("SELECT * FROM AP_LoadFiles WHERE LoopThroughFile=0 And ProjectID=" & CurProjectID & " Order by LoadFileID Desc")
            
            Do Until Rs1.EOF
                VLoadCategoryID = Rs1("LoadCategoryID")
                VLoopThroughFile = Rs1("LoopThroughFile")
                
                If Not IsNull(Rs1("RenameTo")) And Rs1("RenameTo") <> "" Then
                    NewFileName = Rs1("RenameTo")
                Else
                    NewFileName = CurFileName
                End If
                
                If (VLoadCategoryID = 2 And CurFileName Like "*" & Rs1("ExcelFileName") & "*") Or _
                   (VLoadCategoryID = 3 And CurFileName = Rs1("ExcelFileName")) Or _
                   VLoadCategoryID = 1 Then
                    FileCopy ProjectNetworkLoadPath & CurFileName, ProjectLocalLoadPath & NewFileName
                    
                    If Not IsNull(Rs1("LoadXLSMFileName")) And Rs1("LoadXLSMFileName") <> "" Then
                        Set ExcelApp = CreateObject("Excel.Application")
                        ExcelApp.Workbooks.Open CurPath & Rs1("LoadXLSMFileName") & ".xlsm", True
                        ExcelApp.Visible = False
                        ExcelApp.Quit
                        Set ExcelApp = Nothing
                    End If
                    
                    FileCopy ProjectNetworkLoadPath & CurFileName, ProjectPreviousPath & FormattedDate & "_" & CurFileName
                End If
                
                Rs1.MoveNext
            Loop
            
            Rs1.Close
            Set Rs1 = Nothing
        Next CurLoadFile
        
        ' 所有文件处理完成后执行一次指定逻辑
        Debug.Print "LoopThroughFile=0的所有文件已处理，执行最终逻辑"
        ' 在这里取消注释RunTest代码
        
        ' 批量清理本地临时文件
        If Len(Dir$(ProjectLocalLoadPath & "*.*")) > 0 Then
            Kill ProjectLocalLoadPath & "*.*"
        End If
    End If
    
    ' 处理无加载配置的情况
    If DCount("LoadFileID", "AP_LoadFiles", "ProjectID=" & CurProjectID) = 0 Then
        Debug.Print "未找到加载指令，执行默认逻辑"
        ' 在这里取消注释RunTest代码
    End If
    
    ' 恢复Access系统提示选项
    Application.SetOption "Confirm Action Queries", True
    Application.SetOption "Confirm Record Changes", True
    Application.SetOption "Confirm Document Deletions", True
End Function

关键修复细节 #

• 移除无效的Exit Do和多余End If：让记录集循环能完整遍历所有配置规则，不会提前终止。
• 预存文件列表到Collection：绕开Dir函数的缓存限制，即使中间删除文件，也能遍历所有初始目录下的文件。
• 调整文件删除时机：把Kill操作放到单个文件的所有配置规则处理完成后，确保每个规则都能生效。
• 优化Excel对象管理：每次创建Excel实例后都主动释放对象，避免后台残留Excel进程。
• 修正路径重复赋值：调整代码顺序，让路径计算逻辑更清晰，避免重复赋值导致的潜在错误。

另外要注意：代码中标记的MainProjectName、CurPath、CurProjectID这几个变量，需要确保在调用这个函数前已经正确赋值，否则会导致路径错误或数据库查询失败。

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