Excel VBA目录扫描宏大数据集耗时激增，求优化方案

你的问题核心是重复遍历目录——原代码每处理一个零件编号就把整个目录扫一遍，9000条数据等于做9000次目录遍历，这完全是性能杀手！下面是针对性的优化方案，能把运行时间从小时级压缩到几秒：

关键优化思路 #

• 一次性读取所有文件名：把目录里的文件全存到字典里，只扫一次目录，之后直接查字典，避免重复IO操作
• 关闭Excel UI交互：暂停屏幕更新、事件触发，减少后台资源消耗，避免"未响应"
• 统一大小写判断：把所有文件名转成小写（或大写），不用重复判断.SLDPRT和.sldprt这种大小写差异
• 批量写入单元格：先把结果存在内存数组里，最后一次性写入工作表，减少和Excel界面的交互次数

优化后的完整代码 #

Sub scanDirectoryOptimized()
    Dim path As String
    Dim fileName As String
    Dim partNumbers As Variant
    Dim results() As Variant
    Dim fileDict As Object
    Dim counterA As Long ' 改用Long，避免Integer溢出（4294超过Integer上限）
    Dim lastRow As Long
    
    ' 初始化字典（用来存所有文件名，转成小写）
    Set fileDict = CreateObject("Scripting.Dictionary")
    fileDict.CompareMode = vbTextCompare ' 不区分大小写
    
    ' 设置目标目录（注意路径格式是"路径\"，不要写反）
    path = "C:\Users\joe.blow\Documents\"
    
    ' --------------------------
    ' 第一步：一次性读取所有目录文件到字典
    ' --------------------------
    fileName = Dir(path & "*.*")
    Do While fileName <> vbNullString
        ' 把文件名转成小写存入字典，键是文件名，值随便（这里用True标记存在）
        fileDict(LCase(fileName)) = True
        fileName = Dir()
    Loop
    
    ' --------------------------
    ' 第二步：读取所有零件编号到数组（批量读取）
    ' --------------------------
    With Sheets("Sheet0")
        lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row ' 自动找最后一行，不用硬写4294
        partNumbers = .Range(.Cells(8, 2), .Cells(lastRow, 2)).Value ' 把B8到最后一行的零件号读进数组
    End With
    
    ' 初始化结果数组（对应E列和F列的结果）
    ReDim results(1 To UBound(partNumbers, 1), 1 To 2) ' 第一维是行，第二维：1=模型/装配体，2=工程图
    
    ' --------------------------
    ' 第三步：批量处理每个零件编号
    ' --------------------------
    For counterA = 1 To UBound(partNumbers, 1)
        Dim partName As String
        partName = Trim(partNumbers(counterA, 1))
        If partName = "" Then
            results(counterA, 1) = "N"
            results(counterA, 2) = "N"
            GoTo NextPart
        End If
        
        ' 检查模型/装配体（.sldprt/.sldasm）
        results(counterA, 1) = "N"
        If fileDict.Exists(LCase(partName & ".sldprt")) Or _
           fileDict.Exists(LCase(partName & ".sldasm")) Then
            results(counterA, 1) = "Y"
        End If
        
        ' 检查工程图（.slddrw）
        results(counterA, 2) = "N"
        If fileDict.Exists(LCase(partName & ".slddrw")) Then
            results(counterA, 2) = "Y"
        End If
        
NextPart:
    Next counterA
    
    ' --------------------------
    ' 第四步：一次性把结果写入工作表
    ' --------------------------
    With Sheets("Sheet0")
        .Range(.Cells(8, 5), .Cells(lastRow, 6)).Value = results ' E8到F最后一行写入结果
    End With
    
    ' 提示完成
    MsgBox "扫描完成！", vbInformation
    
    ' 清理对象
    Set fileDict = Nothing
End Sub

额外的性能小技巧 #

1. 开启手动计算：如果你的工作表有大量公式，可以在代码开头加Application.Calculation = xlCalculationManual，结尾加Application.Calculation = xlCalculationAutomatic
2. 禁用事件：开头加Application.EnableEvents = False，结尾加Application.EnableEvents = True，避免触发不必要的工作表事件
3. 避免硬编码行号：原代码里的4294改成自动找最后一行，更灵活也避免遗漏数据

这样改完后，9000条数据应该能在几秒内跑完，而且不会出现未响应的情况！

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