Excel VBA宏优化需求：过滤无结果时跳过复制粘贴步骤

原宏的核心问题是未判断过滤后是否存在有效数据行：当目标列全为0时，Range("A2").End(xlDown)会选中A2到工作表末尾的所有单元格，导致错误复制无关内容。以下是修改后的代码，实现"无过滤结果则跳过复制"的需求：

Sub ProactiveHTAT()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim visibleRange As Range
    Dim lastRow As Long
    
    ' 初始化源工作表（假设数据在Sheet1）
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    ' 清除现有筛选
    wsSource.AutoFilterMode = False
    
    ' 第一步：筛选第19列=Pass，第7列<>0，复制A列到新工作表
    With wsSource.Range("$A$1:$T$1000")
        .AutoFilter Field:=19, Criteria1:="Pass"
        .AutoFilter Field:=7, Criteria1:="<>0"
        
        ' 获取可见的A列数据行（排除表头）
        On Error Resume Next
        Set visibleRange = .Columns(1).Offset(1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        ' 若有可见数据则复制
        If Not visibleRange Is Nothing Then
            Set wsTarget = ThisWorkbook.Sheets.Add(After:=wsSource)
            visibleRange.Copy wsTarget.Range("A1")
        End If
        ' 清除第7列筛选
        .AutoFilter Field:=7
    End With
    
    ' 第二步：筛选第8列<>0，复制A列到目标表（若目标表已存在）
    With wsSource.Range("$A$1:$T$1000")
        .AutoFilter Field:=8, Criteria1:="<>0"
        
        On Error Resume Next
        Set visibleRange = .Columns(1).Offset(1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not visibleRange Is Nothing Then
            ' 检查目标表是否存在，不存在则创建
            On Error Resume Next
            Set wsTarget = ThisWorkbook.Sheets("Sheet2")
            On Error GoTo 0
            If wsTarget Is Nothing Then Set wsTarget = ThisWorkbook.Sheets.Add(After:=wsSource)
            
            ' 找到目标表最后一行，粘贴到下一行
            lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
            visibleRange.Copy wsTarget.Range("A" & lastRow + 1)
        End If
        ' 清除第8列筛选
        .AutoFilter Field:=8
    End With
    
    ' 第三步：筛选第10列<>0，复制A列到目标表
    With wsSource.Range("$A$1:$T$1000")
        .AutoFilter Field:=10, Criteria1:="<>0"
        
        On Error Resume Next
        Set visibleRange = .Columns(1).Offset(1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not visibleRange Is Nothing Then
            ' 确保目标表存在
            On Error Resume Next
            Set wsTarget = ThisWorkbook.Sheets("Sheet2")
            On Error GoTo 0
            If wsTarget Is Nothing Then Set wsTarget = ThisWorkbook.Sheets.Add(After:=wsSource)
            
            lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
            visibleRange.Copy wsTarget.Range("A" & lastRow + 1)
        End If
        ' 清除所有筛选
        wsSource.AutoFilterMode = False
    End With
    
    ' 去重（仅当目标表存在且有数据时执行）
    If Not wsTarget Is Nothing Then
        lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
        If lastRow >= 1 Then
            wsTarget.Range("A1:A" & lastRow).RemoveDuplicates Columns:=1, Header:=xlNo
        End If
    End If
End Sub

关键改进说明 #

• 空结果判断：通过SpecialCells(xlCellTypeVisible)获取过滤后的可见行，配合错误捕获判断是否存在有效数据，无数据则跳过复制步骤。
• 避免Select/Activate：直接引用工作表和单元格对象，避免因选中状态变化导致的错误，同时提升宏的运行效率。
• 鲁棒性优化：增加目标表存在性检查，防止因表不存在导致的运行错误；最后统一清除筛选状态，避免影响后续操作。

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