VBA文件集合筛选异常：仅添加近7年文件时Excel崩溃求助

问题背景 #

现有VBA代码可批量合并指定文件夹内的Excel工作簿至单个工作表，但添加仅保留4位年份开头（如2019_M05）的近7年文件的筛选逻辑后，Excel无报错直接崩溃。待合并数据量超50万行。

崩溃原因 #

你编写的筛选逻辑存在两个核心问题：

1. 年份提取错误：使用Left(strFile,2)仅提取了年份前两位（如2019取为20），与单元格内的4位年份（如2016）比较时逻辑完全错误，同时存在类型不匹配风险。
2. 死循环：仅当文件符合条件时才调用strFile = Dir更新文件名，不符合条件时循环无法推进，导致Excel资源耗尽崩溃。

修复后的筛选逻辑 #

替换原代码中收集文件名的循环部分，以下是修正后的代码：

'Store all of the file names in a collection
Dim fileYear As Long
Dim minYear As Long

'提前读取最小年份并转成数值，减少单元格交互次数提升性能
minYear = CLng(wb1.Sheets("Start Here").Range("B12").Value)

strFile = Dir(strDirContainingFiles & "\*.xlsx")
Do While Len(strFile) > 0
    '先判断文件名前4位是否为数字，避免非目标格式文件引发错误
    If IsNumeric(Left(strFile, 4)) Then
        fileYear = CLng(Left(strFile, 4))
        '筛选年份大于等于设定值的文件
        If fileYear >= minYear Then
            colFileNames.Add Item:=strFile
        End If
    End If
    '必须每次循环都调用Dir更新文件名，避免死循环
    strFile = Dir
Loop

50万+行大数据量优化建议 #

针对超大数据量，原代码的复制粘贴方式效率低且易崩溃，建议补充以下优化：

• 改用数组读写数据：将源工作表数据读入内存数组，再写入目标工作表，避免频繁的工作表IO操作，速度提升数倍。
• 强化Excel环境设置：在代码开头添加：

  Application.CutCopyMode = False
  Application.DisplayAlerts = False
  

• 减少重复查找操作：每次写入数据后记录当前最后行号，无需反复调用LastOccupiedRowNum函数。
• 批量填充来源文件名：将来源文件名信息存入数组，与数据一起写入，避免逐行填充。
• 备选方案：Power Query：若无需VBA自动化，Power Query处理大数据量合并更稳定高效，无需担心内存溢出问题。

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