如何优化Excel VBA工作表对比代码以提升大表格运行速度？

原代码功能为对比Sheet1与Sheet2数据，将变更信息记录至Sheet3，但处理大型表格时因嵌套循环、重复查找、逐单元格写入等问题，运行效率极低。以下是针对性优化措施及完整优化代码：

核心优化点 #

• 用字典预存索引：将Sheet2中人员编号（B列）与行索引的映射提前存入字典，避免每次对比时全表遍历查找，将时间复杂度从O(n²)降至O(n)
• 预存表头映射：提前提取两个表的表头与列索引对应关系，避免重复调用查找表头的函数
• 批量写入结果：将变更信息先存入数组，最后一次性写入Sheet3，大幅减少Excel单元格IO操作
• 关闭Excel后台操作：运行时关闭屏幕更新、自动计算、事件触发，消除不必要的系统开销
• 修复原代码笔误：修正第二个循环中Data(i,2)的错误写法为data2(i,2)

优化后完整代码 #

Sub CompareSheetsAndLogChangesColumnB()
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim pernumsSheet1 As Object, pernumsSheet2 As Object
    Dim data1 As Variant, data2 As Variant, results As Variant
    Dim headers1 As Object, headers2 As Object
    Dim i As Long, j As Long, changeRow As Long
    Dim pernum As String, changeDetails As String
    
    ' 关闭Excel后台操作提升速度
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    ' 初始化工作表
    Set ws1 = wb.Sheets("Sheet1")
    Set ws2 = wb.Sheets("Sheet2")
    Set ws3 = wb.Sheets("Sheet3")
    
    ' 清空Sheet3并设置表头
    ws3.Cells.Clear
    ws3.Cells(1, 1).Value = "Personal Number"
    ws3.Cells(1, 2).Value = "Explanation"
    
    ' 将数据读入数组（内存操作远快于单元格操作）
    data1 = ws1.UsedRange.Value
    data2 = ws2.UsedRange.Value
    
    ' 预构建字典：Sheet1的人员编号去重，Sheet2的人员编号对应行索引
    Set pernumsSheet1 = CreateObject("Scripting.Dictionary")
    Set pernumsSheet2 = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(data2, 1)
        pernum = data2(i, 2)
        If Not pernumsSheet2.Exists(pernum) Then
            pernumsSheet2.Add pernum, i
        End If
    Next i
    
    ' 预构建表头映射字典：表头文本对应列索引
    Set headers1 = CreateObject("Scripting.Dictionary")
    Set headers2 = CreateObject("Scripting.Dictionary")
    For j = LBound(data1, 2) To UBound(data1, 2)
        headers1.Add data1(1, j), j
    Next j
    For j = LBound(data2, 2) To UBound(data2, 2)
        headers2.Add data2(1, j), j
    Next j
    
    ' 初始化结果数组（预估最大行数，避免动态扩容）
    ReDim results(1 To UBound(data1, 1) + UBound(data2, 1), 1 To 2)
    changeRow = 1
    
    ' 对比Sheet1中的每条记录在Sheet2中的变化
    For i = 2 To UBound(data1, 1)
        pernum = data1(i, 2)
        pernumsSheet1.Add pernum, 0 ' 标记Sheet1存在的编号
        
        If pernumsSheet2.Exists(pernum) Then
            changeDetails = ""
            Dim rowNum2 As Long: rowNum2 = pernumsSheet2(pernum)
            ' 对比共同表头对应的列
            For Each key In headers1.Keys
                If headers2.Exists(key) Then
                    Dim col1 As Long: col1 = headers1(key)
                    Dim col2 As Long: col2 = headers2(key)
                    If data1(i, col1) <> data2(rowNum2, col2) Then
                        changeDetails = changeDetails & key & ": " & data1(i, col1) & " changed to " & data2(rowNum2, col2) & ", "
                    End If
                End If
            Next key
            ' 处理末尾逗号
            If Len(changeDetails) > 0 Then
                changeDetails = Left(changeDetails, Len(changeDetails) - 2)
            End If
        Else
            changeDetails = "Personal Number not found in the second sheet"
        End If
        
        If changeDetails <> "" Then
            changeRow = changeRow + 1
            results(changeRow, 1) = pernum
            results(changeRow, 2) = changeDetails
        End If
    Next i
    
    ' 找出Sheet2中存在但Sheet1中没有的记录
    For i = 2 To UBound(data2, 1)
        pernum = data2(i, 2)
        If Not pernumsSheet1.Exists(pernum) Then
            changeRow = changeRow + 1
            results(changeRow, 1) = pernum
            results(changeRow, 2) = "Not Found in the first sheet"
        End If
    Next i
    
    ' 批量写入结果到Sheet3
    If changeRow > 1 Then
        ws3.Range("A2:B" & changeRow).Value = results(2 To changeRow, 1 To 2)
    End If
    
    ' 恢复Excel默认设置
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End Sub

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