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

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