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

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

    Sub copy_filter(Changed)
        Dim rang As Range

        Set sh = Worksheets("Sheet2")

        sh.UsedRange.AutoFilter Field:=3, _
                                Criteria1:="=" & Changed.Value, _
                                VisibleDropDown:=False


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

        On Error Resume Next
        Set rang = rang.SpecialCells(xlCellTypeVisible)
        If Err.Number = 0 Then
            rang.Copy
            Worksheets("Sheet1").Range(Changed.Address).Offset(0, 1).PasteSpecial Paste:=xlPasteValues
        End If

        On Error GoTo 0

        sh.Cells.AutoFilter

        Application.CutCopyMode = False


    End Sub