VBA按部分文件名匹配提取文件夹内指定Excel文件单元格数据

原有方案问题 #

• 原脚本遍历目标文件夹下全量Excel文件提取指定单元格数据，目标文件夹内文件超1000个时，大量无效读取操作易导致Excel程序崩溃
• 实际业务仅需提取20-30个目标文件数据，全量遍历无必要
• 目标文件判定规则：主工作表B列预置数字编码（如3333、44444、562872），文件名包含对应编码即为目标文件（例：ABCD 3333 BDBD.xlsx、AJKP 4444.xls均属于匹配范围）

原有可运行基础代码 #

Sub Macro()

 Dim StrFile As String, TargetWb As Workbook, ws As Worksheet, i As Long, StrFormula As String
 Const strPath As String = "\\pco.X.com\Y\OPERATIONS\X\SharedDocuments\Regulatory\Z\X\" '路径末尾需保留反斜杠

 Set TargetWb = Workbooks("X.xlsm")
 Set ws = TargetWb.Sheets("Macro")
 i = 3

 StrFile = Dir(strPath & "*.xls*") '匹配xls/xlsx/xlsm/xlsa/xlsb所有格式Excel文件
 Dim sheetName As String: sheetName = "S"
 Do While Len(StrFile) > 0
     StrFormula = "'" & strPath & "[" & StrFile & "]" & sheetName
     ws.Range("B" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R24C3")
     ws.Range("A" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R3C2")
    
    i = i + 1
    StrFile = Dir() '遍历下一个文件
 Loop
 
End Sub

优化后实现方案 #

核心优化逻辑 #

• 遍历前一次性将B列预置编码读入内存数组，避免逐文件读取单元格产生的性能损耗
• 遍历文件时先做编码匹配校验，仅命中编码的文件才执行单元格数据提取，跳过97%以上的无关文件，从根源避免无效操作导致的程序崩溃
• 增加容错处理，个别文件损坏、被占用或无目标工作表时自动跳过，不会中断整体运行
• 匹配逻辑为文件名包含编码即命中，不区分大小写，自动忽略编码前后空格

优化后完整代码 #

Sub ExtractMatchedFileData()
    Dim StrFile As String, TargetWb As Workbook, ws As Worksheet, i As Long, StrFormula As String
    Dim strPath As String, sheetName As String
    Dim codeArr As Variant, matchFlag As Boolean, codeItem As Variant
    Dim lastCodeRow As Long
    
    ' -------------------------- 按需修改以下配置项 --------------------------
    strPath = "\\pco.X.com\Y\OPERATIONS\X\SharedDocuments\Regulatory\Z\X\" ' *注意：路径末尾必须带反斜杠*
    sheetName = "S" ' 待提取数据的源工作表名称
    Const codeCol As String = "B" ' 预置编码所在列
    Const codeStartRow As Long = 2 ' 预置编码列表起始行（默认跳过第1行表头）
    Const outputStartRow As Long = 3 ' 提取结果在主表的输出起始行
    ' -----------------------------------------------------------------------------
    
    ' 绑定主工作簿与输出工作表
    Set TargetWb = Workbooks("X.xlsm")
    Set ws = TargetWb.Sheets("Macro")
    
    ' 读取所有预置编码到内存数组
    lastCodeRow = ws.Cells(ws.Rows.Count, codeCol).End(xlUp).Row
    If lastCodeRow < codeStartRow Then
        MsgBox "未在B列检测到预置编码列表，请检查配置后重试", vbExclamation
        Exit Sub
    End If
    codeArr = ws.Range(codeCol & codeStartRow & ":" & codeCol & lastCodeRow).Value
    
    ' 清空历史输出内容（不需要可注释该行）
    ws.Range("A" & outputStartRow & ":B" & ws.Rows.Count).ClearContents
    
    i = outputStartRow
    StrFile = Dir(strPath & "*.xls*")
    
    Do While Len(StrFile) > 0
        matchFlag = False
        ' 校验当前文件名是否命中任意预置编码
        For Each codeItem In codeArr
            If Not IsError(codeItem) And Trim(CStr(codeItem)) <> "" Then
                If InStr(1, StrFile, Trim(CStr(codeItem)), vbTextCompare) > 0 Then
                    matchFlag = True
                    Exit For
                End If
            End If
        Next codeItem
        
        ' 仅匹配成功的文件执行数据提取
        If matchFlag Then
            StrFormula = "'" & strPath & "[" & StrFile & "]" & sheetName
            On Error Resume Next
            ws.Range("B" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R24C3")
            ws.Range("A" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R3C2")
            ' 需提取更多单元格可参照上方格式新增，例：提取R5C4单元格写入C列
            ' ws.Range("C" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R5C4")
            On Error GoTo 0
            i = i + 1
        End If
        
        StrFile = Dir
    Loop
    
    MsgBox "提取完成，共匹配处理" & i - outputStartRow & "个目标文件", vbInformation
End Sub

使用说明 #

• 首次运行前请核对代码开头配置项，确保路径、工作表名称、行列位置与实际场景一致
• 预置编码列请勿留连续空行，空单元格会自动跳过不参与匹配
• 优化后仅对20-30个目标文件执行数据读取操作，运行速度较原脚本提升数十倍，不会出现程序无响应、崩溃问题

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