优化百万行Excel工作表VBA合并脚本及代码疑问

需求背景 #

处理两个各约100万行的Excel工作表，现有VBA脚本运行效率极低，需优化并完成以下操作：

• 以A列为共同标识合并Sheet1与Sheet2
• 添加列判断E列与H列是否相等（返回True/False）
• 删除所有值为True的行（最终仅余数百行）

代码片段解读 #

针对以下两段核心代码，解释关键元素含义并验证匹配逻辑：

iRow = Application.Match(ID, ws2.UsedRange.Columns(1), 0)
If Not IsError(iRow) Then ws2.Range("A" & iRow & ":M" & iRow).Copy ws3.Range("G" & r.Row)

元素含义 #

• Columns(1)：指代ws2已使用区域的第1列（即A列），是Match函数的查找范围
• A：ws2中要复制的起始列（A列）
• :M：ws2中要复制的结束列（M列），即复制该行从A到M的所有单元格内容
• G：ws3中粘贴的起始列（G列），将ws2对应行的A-M列内容粘贴到ws3当前行的G列起始位置

匹配逻辑验证 #

这段代码的逻辑是正确的：

1. 从ws3当前行的A列取出ID值
2. 在ws2的A列中查找该ID对应的行号
3. 找到匹配行后，将ws2该行的A-M列内容复制到ws3对应行的G列开始位置

原代码效率瓶颈分析 #

原代码分为三个子过程，存在以下导致运行缓慢的问题：

1. 逐行循环匹配：TestGridUpdate中使用For Each r In ws3.UsedRange.Rows逐行遍历100万行数据，每次调用Application.Match都会触发Excel单元格交互，时间复杂度为O(n²)，速度极慢
2. 单元格操作冗余：直接对单元格执行复制、公式填充等操作，未使用数组批量处理，IO开销巨大
3. 不必要的工作表激活：FillFormula和Delete_Rows_Based_On_Value中调用ws.Activate，激活工作表会增加额外系统开销

优化后的VBA代码 #

核心优化点 #

• 使用数组批量读取/写入数据，彻底减少单元格交互次数
• 使用字典（Dictionary）存储ws2的ID映射，将Match的O(n)查找变为O(1)的哈希查找
• 避免工作表激活，直接通过对象操作数据
• 提前筛选需保留的行，跳过低效的删除行操作

Sub OptimizedProcess()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim dict As Object
    Dim arr1 As Variant, arr2 As Variant, arrResult As Variant
    Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long
    Dim keepCount As Long
    
    ' 初始化工作表对象
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 处理Combined工作表：存在则清空，不存在则新建
    On Error Resume Next
    Set ws3 = ThisWorkbook.Worksheets("Combined")
    On Error GoTo 0
    If ws3 Is Nothing Then
        Set ws3 = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        ws3.Name = "Combined"
    Else
        ws3.Cells.Clear
    End If
    
    ' 批量读取Sheet1和Sheet2数据到数组
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    arr1 = ws1.Range("A1:M" & lastRow1).Value
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    arr2 = ws2.Range("A1:M" & lastRow2).Value
    
    ' 构建ID到行数据的字典映射
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 2 To lastRow2 ' 跳过表头行
        If Not dict.Exists(arr2(i, 1)) Then
            Dim rowArr As Variant
            ReDim rowArr(1 To 13) ' 存储A-M列共13个单元格数据
            For j = 1 To 13
                rowArr(j) = arr2(i, j)
            Next j
            dict(arr2(i, 1)) = rowArr
        End If
    Next i
    
    ' 构建临时结果数组（含E列与H列的判断列）
    ReDim arrResult(1 To lastRow1, 1 To 14) ' 原13列 + 判断列N
    ' 复制表头
    For j = 1 To 13
        arrResult(1, j) = arr1(1, j)
    Next j
    arrResult(1, 14) = "E=H?"
    
    ' 批量处理数据合并与相等判断
    keepCount = 0
    For i = 2 To lastRow1
        ' 复制Sheet1当前行数据
        For j = 1 To 13
            arrResult(i, j) = arr1(i, j)
        Next j
        
        ' 匹配Sheet2数据并填充到G列（第7列）开始的位置
        If dict.Exists(arr1(i, 1)) Then
            Dim matchRow As Variant
            matchRow = dict(arr1(i, 1))
            For j = 1 To 13
                arrResult(i, 6 + j) = matchRow(j) ' G列对应数组索引7=6+1
            Next j
        End If
        
        ' 判断E列（第5列）与H列（第8列）是否相等
        arrResult(i, 14) = (arrResult(i, 5) = arrResult(i, 8))
        
        ' 统计需保留的行（判断结果为False）
        If Not arrResult(i, 14) Then
            keepCount = keepCount + 1
        End If
    Next i
    
    ' 生成最终保留的结果数组
    Dim finalArr As Variant
    ReDim finalArr(1 To keepCount + 1, 1 To 14) ' +1是表头行
    ' 复制表头
    For j = 1 To 14
        finalArr(1, j) = arrResult(1, j)
    Next j
    
    ' 筛选出需保留的行
    Dim k As Long
    k = 2
    For i = 2 To lastRow1
        If Not arrResult(i, 14) Then
            For j = 1 To 14
                finalArr(k, j) = arrResult(i, j)
            Next j
            k = k + 1
        End If
    Next i
    
    ' 将最终数组写入Combined工作表
    ws3.Range("A1").Resize(UBound(finalArr, 1), UBound(finalArr, 2)).Value = finalArr
    
    ' 释放对象
    Set dict = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Set ws3 = Nothing
    
    MsgBox "处理完成！共保留 " & keepCount & " 行数据。"
End Sub

优化效果说明 #

• 字典查找将逐行匹配的时间复杂度从O(n²)降至O(n)，百万级数据处理速度提升数十倍
• 数组批量读写彻底避免了频繁的单元格交互，大幅减少IO开销
• 提前筛选需保留的行，跳过了低效的删除行操作，进一步提升运行效率

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