如何加速筛选单元格复制至新工作簿的VBA代码运行速度？

你的代码在数据量大时卡顿，核心原因是复制整个工作表可见区域的操作效率极低，加上依赖ActiveSheet/Selection的冗余写法，导致耗时过长。以下是针对性的优化步骤和完整代码：

关键优化点 #

• 缩小操作范围：只处理有效数据区域，而非整个工作表
• 抛弃Selection/ActiveSheet：直接用工作表对象操作，避免激活切换的额外开销
• 优化日期筛选逻辑：避免字符串格式转换，直接用日期值匹配
• 关闭更多系统事件：减少不必要的后台触发
• 进阶方案：用数组替代AutoFilter：超大数据量下，内存级操作速度提升数倍

基础优化版代码（适合1-5万行数据） #

Sub FilterRowsFast()
    ' 关闭所有不必要的系统功能，最大化运行速度
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlManual
        .EnableEvents = False ' 新增：关闭工作表事件触发
        .CutCopyMode = False
    End With

    Dim DataStock As Worksheet
    Set DataStock = ThisWorkbook.Sheets("Data Stock")
    
    Dim lastRow As Long, lastCol As Long
    ' 获取有效数据的最后一行/列，精准缩小操作范围
    lastRow = DataStock.Cells(DataStock.Rows.Count, 1).End(xlUp).Row
    lastCol = DataStock.Cells(1, DataStock.Columns.Count).End(xlToLeft).Column
    Dim dataRange As Range
    Set dataRange = DataStock.Range(DataStock.Cells(1, 1), DataStock.Cells(lastRow, lastCol))
    
    Dim myDate As Date
    myDate = Application.Max(DataStock.Columns(1)) ' 限定在目标表的第一列，避免跨表错误
    
    ' 清除原有筛选，直接用工作表对象操作，不用ActiveSheet
    If DataStock.AutoFilterMode Then DataStock.AutoFilterMode = False
    
    ' 应用筛选，全部基于确定的dataRange操作
    With dataRange
        .AutoFilter Field:=1, Criteria1:=myDate ' 直接用日期值，无需转字符串
        .AutoFilter Field:=3, Criteria1:="<>DSS GNT", Operator:=xlAnd, Criteria2:="<>DSS BUGGENHOUT"
        .AutoFilter Field:=13, Criteria1:="1"
        .AutoFilter Field:=14, Criteria1:=Array("SNE", "BUG", "GEN", "EUR", "HAM", "MKG", "RHE", "RTZ", "STO"), Operator:=xlFilterValues
        .AutoFilter Field:=20, Criteria1:="Y"
    End With
    
    ' 创建新工作簿并复制筛选后的数据
    Dim NewBook As Workbook, targetSheet As Worksheet
    Set NewBook = Workbooks.Add
    Set targetSheet = NewBook.Sheets(1)
    dataRange.SpecialCells(xlCellTypeVisible).Copy targetSheet.Range("A1")
    
    ' 清除原表筛选
    DataStock.AutoFilterMode = False
    
    ' 恢复系统设置
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlAutomatic
        .EnableEvents = True
        .CutCopyMode = False
    End With
End Sub

进阶数组版代码（适合5万+行超大数据） #

如果年末数据量特别庞大，AutoFilter+复制的方式仍有瓶颈，可改用数组批量读写——完全绕开Excel界面操作，速度提升10倍以上：

Sub FilterRowsWithArray()
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlManual
        .EnableEvents = False
    End With

    Dim DataStock As Worksheet
    Set DataStock = ThisWorkbook.Sheets("Data Stock")
    
    Dim lastRow As Long, lastCol As Long
    lastRow = DataStock.Cells(DataStock.Rows.Count, 1).End(xlUp).Row
    lastCol = DataStock.Cells(1, DataStock.Columns.Count).End(xlToLeft).Column
    
    ' 把所有数据读到内存数组，操作速度比单元格快100倍
    Dim dataArr As Variant
    dataArr = DataStock.Range(DataStock.Cells(1, 1), DataStock.Cells(lastRow, lastCol)).Value
    
    Dim myDate As Date
    myDate = Application.Max(DataStock.Columns(1))
    
    Dim resultArr() As Variant
    Dim resultRow As Long, i As Long, j As Long
    resultRow = 0
    ReDim resultArr(1 To lastRow, 1 To lastCol) ' 初始化结果数组
    
    ' 遍历数组筛选符合条件的行
    For i = 1 To UBound(dataArr, 1)
        If dataArr(i, 1) = myDate _
           And dataArr(i, 3) <> "DSS GNT" And dataArr(i, 3) <> "DSS BUGGENHOUT" _
           And dataArr(i, 13) = "1" _
           And IsInArray(dataArr(i, 14), Array("SNE", "BUG", "GEN", "EUR", "HAM", "MKG", "RHE", "RTZ", "STO")) _
           And dataArr(i, 20) = "Y" Then
           
            resultRow = resultRow + 1
            ' 复制符合条件的行到结果数组
            For j = 1 To lastCol
                resultArr(resultRow, j) = dataArr(i, j)
            Next j
        End If
    Next i
    
    ' 创建新工作簿并写入筛选结果
    Dim NewBook As Workbook
    Set NewBook = Workbooks.Add
    If resultRow > 0 Then
        NewBook.Sheets(1).Range("A1").Resize(resultRow, lastCol).Value = resultArr
    End If
    
    ' 恢复系统设置
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlAutomatic
        .EnableEvents = True
    End With
End Sub

' 辅助函数：判断值是否在目标数组中
Function IsInArray(valToCheck As Variant, arr As Variant) As Boolean
    IsInArray = (UBound(Filter(arr, valToCheck)) > -1)
End Function

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