Excel VBA大数据处理代码运行缓慢，求优化方案

我编写了一段Excel VBA代码，功能为复制当前工作簿，按数组中的值依次保留对应行、删除其他行后保存工作簿，循环处理数组中所有值。但该代码在25万行50列的大数据集下运行极慢，希望获得优化方法。

原代码 #

Sub Code2()
    Dim CurrentWB As Workbook
    Dim NewWB As Workbook
    Dim FilePath As String
    Dim NewFilePath As String
    Dim NewWorkbookName As String
    Dim ws As Worksheet
    Dim KeepValues As Variant
    Dim wsNames As Variant
    Dim wsName As Variant
    Dim lastRow As Long
    Dim i As Long
    Dim rng As Range
    Dim cell As Range
    Dim val As Variant
    ' Array of values to keep
    KeepValues = Array("Val1", "Val2", Val3)

    ' Array of worksheet names
    wsNames = Array("Sheet1","Sheet2")

    Set CurrentWB = ThisWorkbook
    FilePath = CurrentWB.FullName
    FolderPath = Left(FilePath, InStrRev(FilePath, "\"))

    For Each val In KeepValues
        NewWorkbookName = val & "_" & CurrentWB.Name
        NewFilePath = FolderPath & NewWorkbookName
        CurrentWB.SaveCopyAs NewFilePath
        Set NewWB = Workbooks.Open(NewFilePath)

        For Each wsName In wsNames
            On Error Resume Next
            Set ws = NewWB.Sheets(wsName)
            On Error GoTo 0

            If Not ws Is Nothing Then
                With ws
                    lastRow = .Cells(.Rows.Count, "CT").End(xlUp).Row
                    Set rng = .Range("CT2:CT" & lastRow)

                    ' Implementing the deletion technique
                    DeleteNotCriteriaRows rng, val

                    .AutoFilterMode = False
                End With
            End If
        Next wsName
        NewWB.RefreshAll
        'NewWB.Close SaveChanges:=True
    Next val
    
End Sub

Sub DeleteNotCriteriaRows( _
        ByVal rg As Range, _
        ByVal Criteria As String)
    Const CriteriaDelimiter As String = ","
    Dim CriteriaList As String
    Dim rgColumn As Range
    Dim rCount As Long

    ' Construct Criteria List String
    CriteriaList = Criteria

    Dim ws As Worksheet
    Dim rgTotal As Range

    Set ws = rg.Worksheet
    rCount = rg.Rows.Count
    Set rgColumn = rg

    Set rgTotal = Intersect(ws.UsedRange, rgColumn.EntireRow)

    Application.ScreenUpdating = False

    Dim rgInsert As Range
    Set rgInsert = rgColumn.Cells(1).Offset(, 1).Resize(, 2).EntireColumn
    rgInsert.Insert xlShiftToRight, xlFormatFromLeftOrAbove

    Dim rgIntegerSequence As Range: Set rgIntegerSequence = rgColumn.Offset(, 1)
    With rgIntegerSequence
        .NumberFormat = "0"
        .Formula = "=ROW()"
        .Value = .Value
    End With

    Dim rgMatch As Range: Set rgMatch = rgColumn.Offset(, 2)
    With rgMatch
        .NumberFormat = "General"
        .Value = Application.Match(rgColumn, Split(CriteriaList, CriteriaDelimiter), 0)
    End With

    rgTotal.Sort rgMatch, xlAscending, , , , , , xlNo

    Dim rgDelete As Range

    On Error Resume Next
    Set rgDelete = Intersect(ws.UsedRange, _
            rgMatch.SpecialCells(xlCellTypeConstants, xlErrors).EntireRow)
    On Error GoTo 0

    If Not rgDelete Is Nothing Then
        rgDelete.Delete xlShiftUp
    End If

    rgTotal.Sort rgIntegerSequence, xlAscending, , , , , , xlNo

    rgInsert.Offset(, -2).Delete xlShiftToLeft

    Application.ScreenUpdating = True
End Sub

核心优化思路及方案 #

1. 避免重复复制/打开大文件 #

原代码每次循环都复制25万行的工作簿并打开，磁盘IO和文件加载开销极大。改为一次性读取原数据到内存数组，直接基于内存数据生成新工作簿，完全跳过复制-打开步骤。

2. 用内存数组替代单元格操作 #

Excel对象模型（Range）的操作速度远低于内存数组。将整表数据读入二维数组，在数组中完成筛选逻辑，再一次性写入新工作表，能大幅提升速度。

3. 关闭Excel后台冗余特性 #

在代码执行前关闭以下特性，执行完成后恢复：

• Application.ScreenUpdating = False：禁止屏幕刷新
• Application.EnableEvents = False：禁止事件触发
• Application.Calculation = xlCalculationManual：设为手动计算

4. 替换低效的删除逻辑 #

原代码通过排序+删除清理数据，大数据集下排序和删除行的操作耗时极高。改为直接筛选符合条件的行写入新表，跳过删除步骤，从根源减少操作量。

5. 批量处理减少重复读取 #

如果KeepValues数组元素较多，可一次性读取所有需要保留的行索引，再分别写入不同工作簿，避免重复读取原数据。

优化后的代码示例 #

Sub OptimizedSplitData()
    Dim CurrentWB As Workbook
    Dim ws As Worksheet
    Dim KeepValues As Variant
    Dim wsNames As Variant
    Dim FolderPath As String
    Dim val As Variant
    Dim wsName As Variant
    Dim lastRow As Long, lastCol As Long
    Dim sourceData As Variant
    Dim filteredData As Variant
    Dim i As Long, j As Long, k As Long
    
    ' 配置参数
    KeepValues = Array("Val1", "Val2", "Val3")
    wsNames = Array("Sheet1", "Sheet2")
    
    Set CurrentWB = ThisWorkbook
    FolderPath = Left(CurrentWB.FullName, InStrRev(CurrentWB.FullName, "\"))
    
    ' 关闭Excel冗余特性
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    For Each wsName In wsNames
        On Error Resume Next
        Set ws = CurrentWB.Sheets(wsName)
        On Error GoTo 0
        
        If Not ws Is Nothing Then
            ' 读取整表数据到内存数组
            lastRow = ws.Cells(ws.Rows.Count, "CT").End(xlUp).Row
            lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
            sourceData = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).Value
            
            ' 按每个保留值生成新文件
            For Each val In KeepValues
                ' 筛选符合条件的行
                k = 1
                ReDim filteredData(1 To lastRow, 1 To lastCol)
                
                ' 保留表头
                For j = 1 To lastCol
                    filteredData(k, j) = sourceData(1, j)
                Next j
                k = k + 1
                
                ' 筛选数据行
                For i = 2 To lastRow
                    If sourceData(i, ws.Columns("CT").Column) = val Then
                        For j = 1 To lastCol
                            filteredData(k, j) = sourceData(i, j)
                        Next j
                        k = k + 1
                    End If
                Next i
                
                ' 调整数组大小（去掉空行）
                ReDim Preserve filteredData(1 To k - 1, 1 To lastCol)
                
                ' 创建新工作簿并写入数据
                Dim newWB As Workbook
                Set newWB = Workbooks.Add
                newWB.Sheets(1).Range("A1").Resize(UBound(filteredData, 1), UBound(filteredData, 2)).Value = filteredData
                
                ' 保存并关闭
                newWB.SaveAs FolderPath & val & "_" & wsName & "_" & CurrentWB.Name
                newWB.Close SaveChanges:=False
                Set newWB = Nothing
            Next val
        End If
    Next wsName
    
    ' 恢复Excel特性
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

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