VBA复制粘贴代码处理大量数据性能下降问题优化咨询

问题背景 #

处理两个工作表共8万行数据，识别差异并导出变更记录到数据库。现有VBA代码可运行，但性能随数据量骤降：1万行耗时2分22秒，2万行耗时10分13秒，8万行预计近2小时，需优化性能。

原代码如下：

Sub Button1_Click()

'Option Explicit
Application.ScreenUpdating = False
Application.EnableEvents = False

Set Day1_Sheet = ThisWorkbook.Sheets("Day1")
Set Day2_Sheet = ThisWorkbook.Sheets("Day2")
Set VBA_Export = ThisWorkbook.Sheets("VBA_Export")

Dim Day1Code, Day2Code As String
Dim Day1CodeRow As Long, Day2CodeRow As Long, CurrentRow As Long, CurrentColumn As Long, AccountsN As Long, n As Long
Dim LastEmptyColumnResult As Long, LastEmptyRowResult As Long
Dim BolUpdated As Boolean
Dim cTime, eTime As Variant

Day1_Sheet_Rows = Day1_Sheet.Cells(Rows.Count, "B").End(xlUp).Row
Day2_Sheet_Rows = Day2_Sheet.Cells(Rows.Count, "B").End(xlUp).Row

LastEmptyColumnResult = 4
LastEmptyRowResult = 2
BolUpdated = False

VBA_Export.Range("A2:E10000").Clear

cTime = Now()

For Each c In Day1_Sheet.Range("B2:B" & Day1_Sheet_Rows)

    BolUpdated = False

    Day1Code = c

    For Each e In Day2_Sheet.Range("B2:B" & Day2_Sheet_Rows)
    
        If c = e Then
        
            Day2Code = e
            Day2CodeRow = e.Row
            CurrentRow = c.Row
            Exit For
            
        End If
    
    Next e

    CurrentColumn = 3
    
    While CurrentColumn <> 17
    
        If Day1_Sheet.Cells(CurrentRow, CurrentColumn).Value = Day2_Sheet.Cells(Day2CodeRow, CurrentColumn).Value Then
    
        Else
            
            If BolUpdated Then
            Else
            
            Day2_Sheet.Rows(Day2CodeRow).EntireRow.Copy VBA_Export.Range("A" & LastEmptyRowResult)
          
            LastEmptyRowResult = LastEmptyRowResult + 1
            
            BolUpdated = True
            
            End If
            
        End If
        
        CurrentColumn = CurrentColumn + 1
        
    Wend

Next c

LastLine:

Set Day1_Sheet = Nothing
Set Day2_Sheet = Nothing

eTime = Now()

MsgBox ("Start Time " & cTime & ".End Time " & eTime)

Debug.Print "Elapsed Time " & eTime - cTime

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

性能瓶颈分析 #

1. 嵌套循环导致的O(n*m)时间复杂度：外层遍历Day1的每行，内层遍历Day2的每行查找匹配，1万行数据就会产生1亿次循环，8万行则是64亿次，这是性能骤降的核心原因。
2. 频繁访问单元格：每次读取Cells都是Excel对象模型的IO操作，速度远慢于内存数组操作。
3. 逐行复制粘贴：Copy/Paste是高开销操作，频繁调用会大幅增加耗时。
4. 变量声明不严谨：未启用Option Explicit，部分变量默认Variant类型，比强类型变量效率低。

优化方案 #

1. 用字典实现O(1)快速查找：将Day2的B列代码与行号存入字典，替代内层循环，把时间复杂度降至O(n)。
2. 数据批量读入内存数组：一次性将两个工作表的目标数据读入数组，减少单元格访问次数。
3. 批量写入结果：先将需要导出的行存入结果数组，最后一次性写入工作表，替代逐行复制。
4. 关闭更多Excel特性：禁用自动计算、状态栏更新等，减少后台开销。
5. 强类型变量声明：启用Option Explicit，明确所有变量类型。

优化后的代码 #

Option Explicit

Sub OptimizedCompareAndExport()
    Dim wsDay1 As Worksheet, wsDay2 As Worksheet, wsExport As Worksheet
    Dim dictDay2 As Object
    Dim arrDay1 As Variant, arrDay2 As Variant, arrExport As Variant
    Dim lastRowDay1 As Long, lastRowDay2 As Long, exportRowCount As Long
    Dim i As Long, j As Long, matchRow As Long
    Dim hasDiff As Boolean
    Dim startTime As Double, elapsedTime As Double
    
    ' 关闭Excel耗时特性
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayStatusBar = False
    End With
    
    ' 初始化工作表对象
    Set wsDay1 = ThisWorkbook.Sheets("Day1")
    Set wsDay2 = ThisWorkbook.Sheets("Day2")
    Set wsExport = ThisWorkbook.Sheets("VBA_Export")
    Set dictDay2 = CreateObject("Scripting.Dictionary")
    
    ' 获取数据行数
    lastRowDay1 = wsDay1.Cells(wsDay1.Rows.Count, "B").End(xlUp).Row
    lastRowDay2 = wsDay2.Cells(wsDay2.Rows.Count, "B").End(xlUp).Row
    
    ' 清空导出表旧数据
    wsExport.Range("A2:XFD" & wsExport.Rows.Count).Clear
    
    ' 将Day2的B列数据存入字典（键=代码，值=行号）
    For i = 2 To lastRowDay2
        If Not dictDay2.Exists(wsDay2.Cells(i, "B").Value) Then
            dictDay2.Add wsDay2.Cells(i, "B").Value, i
        End If
    Next i
    
    ' 批量读入数据到数组（B列到Q列，对应原代码的B到17列）
    arrDay1 = wsDay1.Range("B2:Q" & lastRowDay1).Value
    arrDay2 = wsDay2.Range("B2:Q" & lastRowDay2).Value
    
    ' 初始化结果数组（预分配足够空间）
    ReDim arrExport(1 To lastRowDay1 - 1, 1 To 16) ' 16列对应B到Q
    exportRowCount = 0
    
    startTime = Timer
    
    ' 遍历Day1数据
    For i = 1 To UBound(arrDay1, 1)
        hasDiff = False
        ' 查找匹配的Day2行号
        If dictDay2.Exists(arrDay1(i, 1)) Then
            matchRow = dictDay2(arrDay1(i, 1)) - 1 ' 数组从1开始，对应原行号-2+1=行号-1
            
            ' 比对C到Q列（数组第2到16列）
            For j = 2 To UBound(arrDay1, 2)
                If arrDay1(i, j) <> arrDay2(matchRow, j) Then
                    hasDiff = True
                    Exit For ' 只要有一个差异就停止比对
                End If
            Next j
            
            ' 有差异则记录该行数据
            If hasDiff Then
                exportRowCount = exportRowCount + 1
                ' 复制Day2对应行的B到Q列数据到结果数组
                For j = 1 To UBound(arrDay2, 2)
                    arrExport(exportRowCount, j) = arrDay2(matchRow, j)
                Next j
            End If
        End If
    Next i
    
    ' 批量写入结果到导出表
    If exportRowCount > 0 Then
        wsExport.Range("A2").Resize(exportRowCount, UBound(arrExport, 2)).Value = arrExport
    End If
    
    elapsedTime = Timer - startTime
    
    ' 恢复Excel特性
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayStatusBar = True
    End With
    
    ' 输出耗时
    MsgBox "处理完成！耗时: " & Format(elapsedTime / 60, "00:00:00")
    Debug.Print "Elapsed Time: " & elapsedTime & " seconds"
    
    ' 释放对象
    Set dictDay2 = Nothing
    Set wsDay1 = Nothing
    Set wsDay2 = Nothing
    Set wsExport = Nothing
End Sub

优化效果说明 #

• 查找操作从O(m)变为O(1)，8万行数据的循环次数从64亿次降至8万次以内。
• 数组操作替代单元格访问，减少99%以上的Excel对象模型调用。
• 批量写入替代逐行复制，大幅降低IO开销。
• 预计8万行数据处理耗时可压缩到1-2分钟以内。

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