如何批量将符合条件的行一次性复制到不同工作簿？

我之前也碰到过类似的大文件逐行复制卡顿问题，用Excel内置的批量筛选功能来替代逐行循环，效率能提升好几个数量级。下面是具体的优化思路和代码：

原代码的低效根源是逐行循环+频繁的复制粘贴操作，每一次循环都会触发Excel的界面刷新和后台计算，数据量越大越卡顿。改用AutoFilter一次性筛选出所有符合条件的行，再批量复制到目标工作簿，能大幅减少操作次数，同时配合关闭Excel的后台冗余设置进一步提速。

Private Sub CommandButton2_Click()
    Dim wsSource As Worksheet
    Dim wbTarget1 As Workbook, wbTarget2 As Workbook
    Dim rngSource As Range, rngFiltered As Range
    Dim lastRow As Long
    Dim conditionOne As String, conditionTwo As String
    
    ' 关闭Excel后台冗余操作，大幅提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 初始化基础变量
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    conditionOne = "value1"
    conditionTwo = "value2"
    lastRow = wsSource.Cells(Rows.Count, 2).End(xlUp).Row
    ' 假设数据范围是A到B列，可根据实际列数调整
    Set rngSource = wsSource.Range("A1:B" & lastRow)
    
    ' 创建目标工作簿
    Set wbTarget1 = Workbooks.Add
    Set wbTarget2 = Workbooks.Add
    
    ' --------------------------
    ' 处理第一个条件：筛选并复制
    ' --------------------------
    With rngSource
        ' 第1列是ID列，匹配conditionOne
        .AutoFilter Field:=1, Criteria1:=conditionOne
        
        ' 捕获筛选后的可见行（跳过表头）
        On Error Resume Next ' 防止无符合条件行时报错
        Set rngFiltered = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not rngFiltered Is Nothing Then
            ' 复制数据到目标工作簿
            rngFiltered.Copy
            wbTarget1.Worksheets(1).Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
            ' 复制表头
            wsSource.Range("A1:B1").Copy wbTarget1.Worksheets(1).Range("A1")
        End If
        
        .AutoFilter ' 清除筛选状态
    End With
    
    ' --------------------------
    ' 处理第二个条件：筛选并复制
    ' --------------------------
    With rngSource
        .AutoFilter Field:=1, Criteria1:=conditionTwo
        
        On Error Resume Next
        Set rngFiltered = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not rngFiltered Is Nothing Then
            rngFiltered.Copy
            wbTarget2.Worksheets(1).Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
            wsSource.Range("A1:B1").Copy wbTarget2.Worksheets(1).Range("A1")
        End If
        
        .AutoFilter
    End With
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "数据拆分完成！"
End Sub

• 后台设置关闭：ScreenUpdating关闭后Excel不会实时刷新界面，EnableEvents避免触发不必要的工作表事件，Calculation设为手动防止每次复制都重新计算，这三项能让代码运行速度提升数倍。
• AutoFilter批量筛选：利用Excel原生的筛选功能一次性定位所有符合条件的行，比逐行判断快得多，尤其是数据量上万行时差距极其明显。
• 错误处理：添加On Error Resume Next防止没有符合条件的行时代码报错，保证程序稳定性。
• 扩展性强：后续要添加更多条件或目标工作簿，只需要重复“筛选-复制-清除筛选”的逻辑块即可，不需要修改核心结构。

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