优化VBA批量提取数据代码：解决效率、中断及文件未关闭问题

我用以下VBA代码提取数据，在家处理3个文件时正常，但在工作电脑处理130个文件夹时遇到三个问题：

1. 运行耗时过长
2. 仅提取54个文件数据后就停止，疑似重复遍历文件夹
3. 提取数据后未关闭打开的.xlsm文件

同时需要实现两种触发方式：工作簿打开时自动更新，或添加按钮手动触发。

优化后完整代码 #

Sub ProcessAllAttendanceFiles()
    ' 常量定义
    Const ROOT_FOLDER As String = "C:\Users\jvittur\OneDrive\Desktop\Attendance"
    Const TARGET_SHEET As String = "DATA PULL - TG"
    Const START_ROW As Long = 12
    
    Dim wsTarget As Worksheet
    Dim currentRow As Long
    Dim fso As Object
    Dim rootFolder As Object
    
    ' 初始化提速设置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    ' 绑定目标工作表并清空原有数据
    Set wsTarget = ThisWorkbook.Sheets(TARGET_SHEET)
    wsTarget.Range(wsTarget.Cells(START_ROW, 2), wsTarget.Cells(wsTarget.Rows.Count, 20)).ClearContents
    currentRow = START_ROW
    
    ' 创建文件系统对象（Late Binding，无需额外引用）
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set rootFolder = fso.GetFolder(ROOT_FOLDER)
    
    ' 递归遍历所有子文件夹并提取数据
    Call TraverseFolder(rootFolder, wsTarget, currentRow)
    
    ' 恢复应用默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    
    MsgBox "数据提取完成！共处理 " & currentRow - START_ROW & " 个文件", vbInformation
End Sub

Private Sub TraverseFolder(folder As Object, wsTarget As Worksheet, ByRef currentRow As Long)
    Dim file As Object
    Dim subFolder As Object
    Dim wbSource As Workbook
    Dim wsAttendance As Worksheet
    Dim wsIncentive As Worksheet
    Dim wsHistory As Worksheet
    
    ' 遍历当前文件夹内的xlsm文件
    For Each file In folder.Files
        If LCase(fso.GetExtensionName(file.Path)) = "xlsm" Then
            On Error Resume Next
            ' 以只读模式打开源文件
            Set wbSource = Workbooks.Open(file.Path, ReadOnly:=True)
            If Err.Number = 0 Then
                ' 绑定源文件内的目标工作表
                Set wsAttendance = wbSource.Sheets("ATTENDANCE RECORD")
                Set wsIncentive = wbSource.Sheets("Perfect Attendance Incentive")
                Set wsHistory = wbSource.Sheets("Crewmember History with Balance")
                
                ' 批量写入数据到目标表（减少单元格操作次数，提升速度）
                With wsTarget
                    .Cells(currentRow, 2).Value = fso.GetBaseName(file.Name)
                    ' 从ATTENDANCE RECORD读取数据
                    .Cells(currentRow, 4).Value = wsAttendance.Range("C4").Value
                    .Cells(currentRow, 5).Value = wsAttendance.Range("E2").Value
                    .Cells(currentRow, 6).Value = wsAttendance.Range("E4").Value
                    .Cells(currentRow, 7).Value = wsAttendance.Range("F2").Value
                    .Cells(currentRow, 17).Value = wsAttendance.Range("F4").Value
                    .Cells(currentRow, 18).Value = wsAttendance.Range("H4").Value
                    .Cells(currentRow, 19).Value = wsAttendance.Range("C4").Value
                    ' 从Perfect Attendance Incentive读取数据
                    .Cells(currentRow, 8).Value = wsIncentive.Range("C14").Value
                    .Cells(currentRow, 9).Value = wsIncentive.Range("D14").Value
                    .Cells(currentRow, 10).Value = wsIncentive.Range("C13").Value
                    .Cells(currentRow, 11).Value = wsIncentive.Range("D13").Value
                    .Cells(currentRow, 12).Value = wsIncentive.Range("C12").Value
                    .Cells(currentRow, 13).Value = wsIncentive.Range("D12").Value
                    .Cells(currentRow, 14).Value = wsIncentive.Range("C11").Value
                    .Cells(currentRow, 15).Value = wsIncentive.Range("D11").Value
                    ' 从Crewmember History读取数据
                    .Cells(currentRow, 16).Value = wsHistory.Range("A1").Value
                End With
                
                currentRow = currentRow + 1
            End If
            ' 关闭源文件，不保存任何修改
            If Not wbSource Is Nothing Then
                wbSource.Close SaveChanges:=False
                Set wbSource = Nothing
            End If
            On Error GoTo 0
        End If
    Next file
    
    ' 递归遍历子文件夹
    For Each subFolder In folder.SubFolders
        Call TraverseFolder(subFolder, wsTarget, currentRow)
    Next subFolder
End Sub

问题解决说明 #

1. 提升运行速度 #

• 禁用ScreenUpdating、EnableEvents、DisplayAlerts，避免界面刷新和弹窗干扰
• 直接遍历文件时读取数据，跳过生成超链接再二次遍历的冗余步骤
• 批量写入数据，减少单个单元格赋值的IO开销
• 以只读模式打开源文件，减少文件锁定和读写冲突

2. 解决遍历停止/重复问题 #

• 采用递归遍历所有层级子文件夹（原代码仅遍历一级子文件夹，会遗漏深层文件）
• 移除硬编码的超链接范围限制（原代码B12:B208），动态记录处理行数
• 添加错误捕获，单个文件读取失败时自动跳过，不中断整个程序

3. 关闭打开的文件 #

• 每次读取完文件后，立即用wbSource.Close SaveChanges:=False关闭工作簿，释放内存资源

触发方式设置 #

工作簿打开自动触发 #

打开ThisWorkbook模块，添加以下代码：

Private Sub Workbook_Open()
    Call ProcessAllAttendanceFiles
End Sub

添加按钮手动触发 #

1. 点击「开发工具」→「插入」→「表单控件按钮」，在工作表中绘制按钮
2. 弹出的「指定宏」窗口中选择ProcessAllAttendanceFiles，点击确定即可

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