如何在VBA中过滤结果为空时跳过复制并继续执行后续逻辑？

修改后的完整代码 #

Sub Macro7()
    Dim wsRef As Worksheet
    Dim wsNov As Worksheet
    Dim lastRow As Long
    Dim visibleRange As Range
    
    ' 初始化工作表对象，避免使用Select/Selection
    Set wsRef = ThisWorkbook.Sheets("Ref2")
    Set wsNov = ThisWorkbook.Sheets("NOV 2022")
    
    ' 第一次筛选：Field3匹配E1，Field4匹配A6，粘贴到当前选中位置
    FilterAndCopy wsRef, wsNov, _
        filterField1:=3, criteria1:=wsNov.Range("E1").Value, _
        filterField2:=4, criteria2:=wsNov.Range("A6").Value, _
        pasteDest:=wsNov.Range(wsNov.Selection.Address)
    
    ' 第二次筛选：Field4匹配A37，粘贴到C37
    FilterAndCopy wsRef, wsNov, _
        filterField2:=4, criteria2:=wsNov.Range("A37").Value, _
        pasteDest:=wsNov.Range("C37")
    
    ' 第三次筛选：Field4匹配A58，粘贴到C58
    FilterAndCopy wsRef, wsNov, _
        filterField2:=4, criteria2:=wsNov.Range("A58").Value, _
        pasteDest:=wsNov.Range("C58")
    
    ' 第四次筛选：Field4匹配A93，粘贴到C93
    FilterAndCopy wsRef, wsNov, _
        filterField2:=4, criteria2:=wsNov.Range("A93").Value, _
        pasteDest:=wsNov.Range("C93")
    
    ' 清除筛选状态（可选，根据需求保留）
    wsRef.AutoFilterMode = False
End Sub

' 封装筛选-复制-粘贴的通用子过程
Private Sub FilterAndCopy(wsSource As Worksheet, wsTarget As Worksheet, _
    Optional filterField1 As Long, Optional criteria1 As Variant, _
    Optional filterField2 As Long, Optional criteria2 As Variant, _
    pasteDest As Range)
    
    Dim lastRow As Long
    Dim visibleDataRange As Range
    
    ' 清除之前的筛选
    wsSource.AutoFilterMode = False
    
    ' 设置筛选条件
    With wsSource.Range("$A$1:$O$168")
        If Not IsMissing(filterField1) And Not IsMissing(criteria1) Then
            .AutoFilter Field:=filterField1, Criteria1:=criteria1
        End If
        If Not IsMissing(filterField2) And Not IsMissing(criteria2) Then
            .AutoFilter Field:=filterField2, Criteria1:=criteria2
        End If
    End With
    
    ' 获取数据区域的最后一行
    lastRow = wsSource.Range("E" & wsSource.Rows.Count).End(xlUp).Row
    
    ' 尝试获取可见数据区域（跳过表头）
    On Error Resume Next
    Set visibleDataRange = wsSource.Range("E2:O" & lastRow).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ' 如果存在可见数据，执行复制粘贴
    If Not visibleDataRange Is Nothing Then
        visibleDataRange.Copy
        pasteDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False ' 清除复制状态
    End If
End Sub

关键改进说明 #

1. 移除Select/Selection：直接通过工作表对象引用范围，避免因工作表切换导致的错误，同时提升代码运行效率。
2. 封装通用子过程：将重复的筛选-复制-粘贴逻辑封装成FilterAndCopy，减少冗余代码，后期修改更方便。
3. 筛选结果判断逻辑：
   • 使用On Error Resume Next捕获SpecialCells(xlCellTypeVisible)的错误（无可见数据时会触发错误）
   • 通过判断visibleDataRange是否为Nothing，决定是否执行复制粘贴操作，无数据则直接跳过
4. 筛选状态管理：每次筛选前清除之前的筛选，避免残留条件影响结果，最后可选清除所有筛选状态。

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