如何优化VBA双层循环，提升Sheet数据匹配效率？

原代码采用嵌套循环遍历两表数据，时间复杂度为O(n*m)，1500行数据时会因频繁的单元格读写和重复计算导致性能低下。以下是基于字典（哈希表）+ 数组批量处理的优化方案，可将耗时降至毫秒级：

核心优化点 #

• 一次性将两表数据读入内存数组，避免反复读写单元格（VBA中单元格IO是性能瓶颈）
• 用Dictionary存储Sheet2处理后的值，将匹配操作从O(m)降为O(1)
• 批量修改数组后一次性写回工作表，减少IO次数

优化后的代码 #

Sub CompareDataOptimized()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim arr1 As Variant, arr2 As Variant
    Dim dict As Object
    Dim i As Long, key As String
    
    ' 初始化工作表对象
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 获取两表最后行号
    lastRow1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row
    
    ' 将数据读入数组（内存操作远快于单元格操作）
    arr1 = ws1.Range("B2:E" & lastRow1).Value
    arr2 = ws2.Range("B2:E" & lastRow2).Value
    
    ' 先处理Sheet2，将清洗后的值存入字典，记录对应行索引
    For i = LBound(arr2, 1) To UBound(arr2, 1)
        ' 清洗值：Trim+移除所有空格
        key = Replace(Trim(arr2(i, 1)), " ", "")
        If key <> "" Then
            ' 若有重复值，可修改为存储行号集合，此处简化为单个行号
            If Not dict.Exists(key) Then
                dict(key) = i
            End If
        End If
    Next i
    
    ' 处理Sheet1，匹配字典中的值
    For i = LBound(arr1, 1) To UBound(arr1, 1)
        ' 仅处理E列为空的行
        If arr1(i, 4) = "" Then
            key = Replace(Trim(arr1(i, 1)), " ", "")
            If dict.Exists(key) Then
                ' 标记Sheet1的E列
                arr1(i, 4) = "PARTIAL"
                ' 标记Sheet2对应的E列
                arr2(dict(key), 4) = "PARTIAL"
            End If
        End If
    Next i
    
    ' 批量写回数据到工作表
    ws1.Range("B2:E" & lastRow1).Value = arr1
    ws2.Range("B2:E" & lastRow2).Value = arr2
    
    ' 释放对象
    Set dict = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
End Sub

额外性能建议 #

• 若需处理大量重复值，可修改字典存储行号数组，实现一对多匹配
• 执行前可添加Application.ScreenUpdating = False和Application.Calculation = xlCalculationManual，执行后恢复默认值，进一步减少耗时

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