多Excel文件数据匹配合并宏执行过慢，求高效优化方案

我来帮你拆解下当前宏的性能瓶颈，然后给出几个能显著提速的优化思路和代码实现——毕竟随着文件数量增加，原代码逐行逐文件重复调用VLookup的方式，确实会让耗时指数级增长。

原代码的核心性能问题 #

• 每次循环行都重复调用5次VLookup，每个VLookup都会重新扫描整个searchRange，完全是重复劳动；
• 逐行遍历主文件的所有行（10到342行），不管该行是否需要填充数据；
• 没有禁用Excel的自动计算功能，每次写入单元格都会触发计算，拖慢速度；
• 每次打开文件后都重复定义searchRange，没有复用内存中的数据。

针对性优化方案 #

下面是几个优先级最高的优化点，按顺序实现就能看到明显的速度提升：

1. 禁用更多Excel后台自动功能

除了ScreenUpdating，还要把自动计算、事件触发都关掉，减少不必要的后台操作：

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual ' 禁用自动计算

记得在错误处理和宏结束时恢复这些设置。

2. 把源文件数据一次性读到内存数组

数组操作是内存级别的，比反复调用VLookup快几个数量级。我们可以把每个源文件的关键数据（Key列+要提取的5列）读到二维数组里，然后用字典快速匹配Key，避免重复扫描：

' 读取源文件数据到数组和字典
Dim wsSource As Worksheet
Set wsSource = sourceFiles.Worksheets("tableName")
Dim lastRow As Long
lastRow = wsSource.Cells(wsSource.Rows.Count, "AE").End(xlUp).Row ' 找到源数据最后一行
Dim sourceData As Variant
sourceData = wsSource.Range("AE1:AJ" & lastRow).Value ' 一次性读取所有数据到数组

' 用字典存储Key和对应的数据，方便快速查找
Dim dataDict As Object
Set dataDict = CreateObject("Scripting.Dictionary")
Dim j As Long
For j = 1 To UBound(sourceData)
    Dim keyVal As Variant
    keyVal = sourceData(j, 1) ' AE列是Key列
    If Not IsEmpty(keyVal) And Not dataDict.Exists(keyVal) Then
        ' 存储第2到第6列的数据（对应原VLookup的2-6列）
        dataDict(keyVal) = Array(sourceData(j, 2), sourceData(j, 3), sourceData(j, 4), sourceData(j, 5), sourceData(j, 6))
    End If
Next j

3. 批量处理需要填充的行

先把主文件中需要填充的行（即Cells(i,35)为空的行）的Key和行号收集起来，不用遍历所有行：

' 先收集主文件中需要填充的行信息
Dim masterNeedFill As Object
Set masterNeedFill = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 10 To 342
    If IsEmpty(Cells(i, 35)) Then
        Dim masterKey As Variant
        masterKey = Cells(i, 31).Value ' 主文件的Key在第31列
        If Not IsEmpty(masterKey) Then
            ' 存储Key对应的行号
            masterNeedFill(masterKey) = i
        End If
    End If
Next i

这样每个源文件只需要处理这些需要填充的Key，不用遍历所有333行（10到342）。

4. 批量写入数据到主文件

找到匹配的Key后，一次性把5列数据写入主文件，避免多次单个单元格写入：

' 遍历需要填充的Key，从字典中查找并写入
Dim key As Variant
For Each key In masterNeedFill.Keys
    If dataDict.Exists(key) Then
        Dim rowNum As Long
        rowNum = masterNeedFill(key)
        ' 一次性写入5列数据，比单个单元格写入快很多
        Cells(rowNum, 32).Resize(1, 5).Value = dataDict(key)
    End If
Next key

完整优化后的代码 #

把这些优化点整合起来，最终的代码如下：

Sub OptimizedDataCrawler()
    On Error GoTo HandleError
    
    ' 禁用Excel后台功能，提升速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim objectFileSys As Object
    Dim objectGetFolder As Object
    Dim file As Object
    Set objectFileSys = CreateObject("Scripting.FileSystemObject")
    Set objectGetFolder = objectFileSys.GetFolder("pathName") ' 替换成你的文件夹路径
    
    ' 先收集主文件中需要填充的行信息（Key和行号）
    Dim masterNeedFill As Object
    Set masterNeedFill = CreateObject("Scripting.Dictionary")
    Dim i As Long
    For i = 10 To 342
        If IsEmpty(Cells(i, 35)) Then
            Dim masterKey As Variant
            masterKey = Cells(i, 31).Value
            If Not IsEmpty(masterKey) Then
                masterNeedFill(masterKey) = i
            End If
        End If
    Next i
    
    ' 遍历文件夹中的每个文件
    For Each file In objectGetFolder.Files
        ' 只处理Excel文件
        If LCase(objectFileSys.GetExtensionName(file.Path)) = "xlsx" Or _
           LCase(objectFileSys.GetExtensionName(file.Path)) = "xls" Then
           
            Dim sourceFiles As Workbook
            ' 优化文件打开参数，避免弹窗和不必要的加载
            Set sourceFiles = Workbooks.Open( _
                Filename:=file.Path, _
                ReadOnly:=True, _
                IgnoreReadOnlyRecommended:=True, _
                UpdateLinks:=xlUpdateLinksNever _
            )
            
            Dim wsSource As Worksheet
            On Error Resume Next ' 防止源文件没有指定工作表
            Set wsSource = sourceFiles.Worksheets("tableName")
            On Error GoTo HandleError
            
            If Not wsSource Is Nothing Then
                ' 读取源文件数据到数组
                Dim lastRow As Long
                lastRow = wsSource.Cells(wsSource.Rows.Count, "AE").End(xlUp).Row
                If lastRow >= 1 Then
                    Dim sourceData As Variant
                    sourceData = wsSource.Range("AE1:AJ" & lastRow).Value
                    
                    ' 构建数据字典
                    Dim dataDict As Object
                    Set dataDict = CreateObject("Scripting.Dictionary")
                    Dim j As Long
                    For j = 1 To UBound(sourceData)
                        Dim keyVal As Variant
                        keyVal = sourceData(j, 1)
                        If Not IsEmpty(keyVal) And Not dataDict.Exists(keyVal) Then
                            dataDict(keyVal) = Array(sourceData(j, 2), sourceData(j, 3), sourceData(j, 4), sourceData(j, 5), sourceData(j, 6))
                        End If
                    Next j
                    
                    ' 批量写入数据到主文件
                    Dim key As Variant
                    For Each key In masterNeedFill.Keys
                        If dataDict.Exists(key) Then
                            Dim rowNum As Long
                            rowNum = masterNeedFill(key)
                            Cells(rowNum, 32).Resize(1, 5).Value = dataDict(key)
                            ' 标记该行已填充，避免后续文件重复处理
                            masterNeedFill.Remove key
                            ' 如果没有需要填充的行，提前退出循环
                            If masterNeedFill.Count = 0 Then Exit For
                        End If
                    Next key
                    
                    Set dataDict = Nothing
                End If
            End If
            
            sourceFiles.Close SaveChanges:=False
            Set sourceFiles = Nothing
            Set wsSource = Nothing
            
            ' 如果没有需要填充的行，提前退出文件循环
            If masterNeedFill.Count = 0 Then Exit For
        End If
    Next file
    
HandleError:
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    If Err.Number <> 0 Then
        MsgBox "Error: " & Err.Description, vbExclamation
    End If
End Sub

额外的提速小技巧 #

• 把主文件的pathName换成绝对路径，避免Excel解析路径的开销；
• 如果源文件数量特别多（比如几百个），可以考虑把所有源文件的数据先合并到一个临时数组/字典里，再一次性写入主文件，减少文件打开关闭的次数；
• 确保源文件的Key列（AE列）没有重复值，或者根据你的需求保留最新的那个值（原代码的VLookup会返回第一个匹配值，优化后的字典也会保留第一个，如果你需要最后一个，就把字典的赋值改成覆盖）。

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