多条件触发VBA复制行至不同工作簿问题及优化需求

嗨，咱们来解决你代码里的两个核心问题：多条件逻辑异常和大数据量下的效率低下。先拆解下原代码的问题，再给你优化后的方案。

原代码问题分析 #

• 多条件逻辑的潜在坑：虽然你用了两个独立的If来判断任一条件，但频繁的Activate/Select切换工作表很容易导致对象引用混乱，偶尔会出现复制错位的情况。
• 效率极低的逐行操作：逐行Copy/Paste是VBA里最慢的操作之一，每一次粘贴都会触发工作表刷新，数据量大的时候卡顿感拉满。

优化方案：批量筛选+一次性复制 #

下面是优化后的代码，核心思路是用AutoFilter批量筛出符合条件的行，一次性复制到目标工作簿，同时彻底抛弃Activate/Select（这是VBA性能优化的关键）：

Private Sub CommandButton2_Click()
    Dim wsSource As Worksheet
    Dim wbTarget1 As Workbook, wbTarget2 As Workbook
    Dim lastRow As Long
    Dim criteria1 As String, criteria2 As String
    
    ' 先关掉屏幕刷新和事件，让代码跑起来更快
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 初始化源工作表和两个目标工作簿
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wbTarget1 = Workbooks.Add
    Set wbTarget2 = Workbooks.Add
    
    ' 读取两个筛选条件
    criteria1 = wsSource.Range("CQ21").Value
    criteria2 = wsSource.Range("CQ22").Value
    
    ' 获取源数据的最后一行（从第9列判断）
    lastRow = wsSource.Cells(wsSource.Rows.Count, 9).End(xlUp).Row
    
    ' 批量复制符合第一个条件的行
    With wsSource
        ' 先清除已有的筛选状态
        .AutoFilterMode = False
        ' 筛选第1列等于criteria1的行（从第10行开始）
        .Range("A9:A" & lastRow).AutoFilter Field:=1, Criteria1:=criteria1
        ' 复制筛选后的可见行，跳过表头（从第10行开始）
        On Error Resume Next ' 处理没有符合条件行的情况，防止报错
        .Range("A10:ZZ" & lastRow).SpecialCells(xlCellTypeVisible).Copy
        On Error GoTo 0
        ' 粘贴到第一个目标工作簿的首行
        If Err.Number = 0 Then
            wbTarget1.Worksheets(1).Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        End If
        ' 清除筛选
        .AutoFilterMode = False
    End With
    
    ' 批量复制符合第二个条件的行，逻辑和上面一致
    With wsSource
        .AutoFilterMode = False
        .Range("A9:A" & lastRow).AutoFilter Field:=1, Criteria1:=criteria2
        On Error Resume Next
        .Range("A10:ZZ" & lastRow).SpecialCells(xlCellTypeVisible).Copy
        On Error GoTo 0
        If Err.Number = 0 Then
            wbTarget2.Worksheets(1).Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        End If
        .AutoFilterMode = False
    End With
    
    ' 恢复屏幕刷新和事件
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "批量复制完成啦！", vbInformation
End Sub

关键优化点说明 #

• 抛弃Activate/Select：直接通过对象引用（比如wsSource、wbTarget1.Worksheets(1)）操作，完全不用切换工作表，既避免了逻辑混乱，又大幅提升速度。
• 批量筛选复制：用AutoFilter一次性选中所有符合条件的行，只做一次复制粘贴，效率比逐行操作高N倍，数据量越大差距越明显。
• 容错处理：加了On Error Resume Next来处理没有符合条件行的情况，不会因为空筛选导致代码崩掉。
• 环境优化：关闭ScreenUpdating和EnableEvents，防止每次操作都刷新屏幕和触发不必要的事件，进一步提速。

额外小建议 #

• 如果你的数据量特别大（比如10万行以上），可以考虑把数据读到数组里处理，再一次性写入目标工作簿，效率还能再上一个台阶。
• 可以给目标工作簿自动设置保存路径和文件名，比如：wbTarget1.SaveAs "C:\你的保存路径\" & criteria1 & ".xlsx"，省得手动保存。

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