如何优化处理11000条数据的VBA代码？

针对11000条数据的处理瓶颈，核心优化思路是减少工作表交互次数、用字典替代嵌套循环查找，具体方案如下：

一、禁用Excel界面相关开销 #

在代码首尾添加以下代码，避免处理过程中频繁刷新界面、触发计算或事件，大幅降低无意义的性能消耗：

' 代码开头
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

' 代码结尾
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

二、批量读写数据到内存数组 #

把Feuil1和Feuil2的所有数据一次性读入内存数组，所有判断、处理都在内存中完成，最后再一次性写入工作表——这是大数量级数据处理提速的核心：

Dim ws1 As Worksheet, ws2 As Worksheet
Dim data1 As Variant, data2 As Variant
Set ws1 = ThisWorkbook.Sheets("Feuil1")
Set ws2 = ThisWorkbook.Sheets("Feuil2")

' 读取Feuil1全量数据（假设数据从A1开始）
data1 = ws1.Range("A1:" & ws1.Cells(ws1.Rows.Count, ws1.Columns.Count).End(xlUp).Address).Value
' 读取Feuil2全量数据
data2 = ws2.Range("A1:" & ws2.Cells(ws2.Rows.Count, ws2.Columns.Count).End(xlUp).Address).Value

三、用字典快速识别新耗材 #

替代逐行嵌套循环比对，用Scripting.Dictionary存储Feuil2已有的耗材标识，遍历Feuil1时直接查字典，时间复杂度从O(n*m)降到O(n+m)：

Dim existingParts As Object
Set existingParts = CreateObject("Scripting.Dictionary")
Dim i As Long

' 把Feuil2的耗材编号（假设在第1列）存入字典
For i = 2 To UBound(data2, 1) ' 跳过表头
    If Not existingParts.Exists(data2(i, 1)) Then
        existingParts.Add data2(i, 1), True
    End If
Next i

' 收集Feuil1中的新耗材（含4个描述列，假设是第2-5列）
Dim newPartsList As Collection
Set newPartsList = New Collection
For i = 2 To UBound(data1, 1)
    If Not existingParts.Exists(data1(i, 1)) Then
        newPartsList.Add Array(data1(i, 1), data1(i, 2), data1(i, 3), data1(i, 4), data1(i, 5))
    End If
Next i

' 批量写入新耗材到Feuil2末尾
If newPartsList.Count > 0 Then
    Dim writeArr() As Variant
    ReDim writeArr(1 To newPartsList.Count, 1 To 5)
    For i = 1 To newPartsList.Count
        writeArr(i, 1) = newPartsList(i)(0)
        writeArr(i, 2) = newPartsList(i)(1)
        writeArr(i, 3) = newPartsList(i)(2)
        writeArr(i, 4) = newPartsList(i)(3)
        writeArr(i, 5) = newPartsList(i)(4)
    Next i
    ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(newPartsList.Count, 5).Value = writeArr
End If

四、预分组领域数据，减少重复遍历 #

先把Feuil1中每个耗材对应的领域信息存入字典，再遍历Feuil2时直接查字典获取领域标记，避免对每个Feuil2耗材都遍历一遍Feuil1：

Dim partDomains As Object
Set partDomains = CreateObject("Scripting.Dictionary")
Dim domainCol As Long ' 假设Feuil1的领域列是第6列
domainCol = 6

' 遍历Feuil1，记录每个耗材的领域（用子字典去重）
For i = 2 To UBound(data1, 1)
    Dim partID As String
    partID = data1(i, 1)
    Dim currentDomain As String
    currentDomain = data1(i, domainCol)
    
    If Not partDomains.Exists(partID) Then
        partDomains.Add partID, CreateObject("Scripting.Dictionary")
    End If
    partDomains(partID)(currentDomain) = True
Next i

' 批量标记Feuil2的领域（假设Flottation标记在第6列，Cyanuration在第7列）
Dim markArr As Variant
markArr = ws2.Range(ws2.Cells(2, 6), ws2.Cells(UBound(data2, 1), 7)).Value

For i = 1 To UBound(markArr, 1)
    partID = data2(i + 1, 1) ' 对应Feuil2的第i+1行数据
    markArr(i, 1) = IIf(partDomains.Exists(partID) And partDomains(partID).Exists("Flottation"), "是", "否")
    markArr(i, 2) = IIf(partDomains.Exists(partID) And partDomains(partID).Exists("Cyanuration"), "是", "否")
Next i

' 写回标记结果
ws2.Range(ws2.Cells(2, 6), ws2.Cells(UBound(data2, 1), 7)).Value = markArr

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