VBA批量汇总同文件夹多Excel单元格数据 代码运行无反应

原代码核心问题 #

• Dir函数调用逻辑错误：一是传入的文件夹路径末尾未补充Excel文件匹配通配符*.xls*，无法匹配到路径下的Excel文件，初始返回空值直接导致循环不执行，这是代码运行无反应的最主要原因；二是Dir仅返回文件名不携带完整路径，直接传给Workbooks.Open无法定位到目标文件；三是循环体内未再次调用Dir获取下一个文件名，即使匹配到第一个文件也无法完成全量遍历。
• 单元格对象写法错误：VBA中工作表的单元格集合属性为Cells，原代码拼写为cell；且Cells仅接受行号、列号作为参数，不能直接传入单元格地址字符串，传入地址需使用Range对象，该错误会触发运行时错误，若开启错误静默忽略就会表现为程序无响应。
• 缺少异常兼容逻辑：未判断源文件是否可正常打开、是否存在名为SCR的工作表，遇到异常会直接中断运行，且不会关闭已打开的源文件造成Excel进程残留。
• 未做无效文件过滤：会尝试打开路径下的非Excel文件、Excel临时文件（~开头的锁文件），甚至把汇总用的主工作簿本身当成源文件打开，造成逻辑错误。

修正后可直接运行的代码 #

Sub 批量汇总SCR表数据()
    Dim StrPath As String, StrFile As String
    Dim TargetWb As Workbook
    Dim SourceWb As Workbook
    Dim i As Long
    Dim SCRSht As Worksheet
    
    ' 关闭屏幕更新、弹窗提示提升运行速度
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 绑定汇总主工作簿
    Set TargetWb = Workbooks("Practice.xlsm")
    ' 清空原有汇总数据（保留表头行，从第2行开始清空）
    TargetWb.Sheets("Sheet1").Range("A2:B" & Rows.Count).ClearContents
    i = 2
    
    ' 源文件所在文件夹路径，末尾必须保留反斜杠
    StrPath = "\\W.X.com\Y\OPERATIONS\Performance-Reporting\SharedDocuments\Regulatory\Z\X\"
    ' 匹配所有版本的Excel文件
    StrFile = Dir(StrPath & "*.xls*")
    
    Do While Len(StrFile) > 0
        ' 跳过主工作簿本身、Excel临时锁文件
        If StrFile <> TargetWb.Name And Left(StrFile, 1) <> "~" Then
            On Error Resume Next
            ' 以只读方式打开源文件，避免文件被锁定无法编辑
            Set SourceWb = Workbooks.Open(Filename:=StrPath & StrFile, ReadOnly:=True)
            ' 仅在文件打开成功时执行后续操作
            If Err.Number = 0 Then
                Set SCRSht = Nothing
                Set SCRSht = SourceWb.Sheets("SCR")
                ' 仅在存在SCR工作表时读取数据
                If Not SCRSht Is Nothing Then
                    TargetWb.Sheets("Sheet1").Range("A" & i).Value = SCRSht.Range("C24").Value
                    TargetWb.Sheets("Sheet1").Range("B" & i).Value = SCRSht.Range("B3").Value
                    i = i + 1
                End If
                ' 关闭源文件，不保存任何更改
                SourceWb.Close SaveChanges:=False
            End If
            On Error GoTo 0
        End If
        ' 关键：获取下一个匹配的文件，缺失会导致循环终止或死循环
        StrFile = Dir
    Loop
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "汇总完成，共收集" & i - 2 & "个文件的数据", vbInformation
End Sub

使用注意事项 #

• 运行代码前必须确保Practice.xlsm处于打开状态，若主汇总工作表名称不是Sheet1，请将代码中对应的工作表名修改为实际名称。
• 若源文件存放路径有调整，直接修改代码中StrPath的赋值即可，注意路径末尾必须保留反斜杠\。
• 若运行时提示权限错误，先手动确认能正常访问对应共享路径、打开路径下的任意Excel文件，再重新运行代码。

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