excel vba - 在自动过滤后选择除标题之外的所有过滤行

Question

我正在尝试编写一个宏来执行以下操作：

• 从 Sheet1 观察我输入的数据的 A 列；
• 当我在 A 列的单元格中写入内容时，使用该值过滤 Sheet2；
• 过滤完成后，将除列标题之外的所有内容从第二张表复制到第一张表中，即使有多个值。

我试着写这个：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Set KeyCells = Range("A:A")
    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
        copy_filter Target
    End If
End Sub

Sub copy_filter(Changed)
    Set sh = Worksheets("Sheet2")
    sh.Select

    sh.Range("$A$1:$L$5943") _
        .AutoFilter Field:=3, _
            Criteria1:="=" & Changed.Value, _
            VisibleDropDown:=False
    Set rang = sh.Range("$A$1:$L$5943") _
        .SpecialCells(xlCellTypeVisible)

    rang.Offset(0, 0).Select
    Selection.Copy

    Worksheets("Sheet1").Select
    Worksheets("Sheet1").Range(Changed.Address).Offset(0, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues

    sh.Range("$A$1:$L$5943").AutoFilter
    Application.CutCopyMode = False
End Sub

但是，当我复制选择时，标题行也会被复制，但是使用 .Offset(1, 0) 会剪切标题和 1 个额外的行，并且不考虑过滤器没有返回结果的情况。

如何选择除标题之外的所有过滤行？

Answer 1

使用sh.UsedRange 会给你一个动态范围。其中，sh.Range("$A$1:$L$5943") 不会缩小和增长以匹配您的数据集。
我们可以像这样修剪标题行：

    Set rang = sh.UsedRange.Offset(1, 0)
    Set rang = rang.Resize(rang.Rows.Count - 1)

但是如果没有数据返回，SpecialCells(xlCellTypeVisible) 会抛出No cells were found. 错误。所以我们必须像这样捕获错误：

On Error Resume Next

Set rang = rang.SpecialCells(xlCellTypeVisible)

If Err.Number = 0 Then

End If

On Error GoTo 0

子副本过滤器（已更改） 暗响为范围 设置 sh = Worksheets("Sheet2") sh.UsedRange.AutoFilter 字段：=3，_ Criteria1:="=" & Changed.Value, _ VisibleDropDown:=假 设置范围 = sh.UsedRange.Offset(1, 0) 设置 rang = rang.Resize(rang.Rows.Count - 1) 出错时继续下一步 设置 rang = rang.SpecialCells(xlCellTypeVisible) 如果 Err.Number = 0 那么 响.复制 Worksheets("Sheet1").Range(Changed.Address).Offset(0, 1).PasteSpecial Paste:=xlPasteValues 万一 错误转到 0 sh.Cells.AutoFilter Application.CutCopyMode = False 结束子