问Excel VBA:从前5行/单元格中筛选和复制

EN

Sub HTH()

    Dim rCopy As Range

    With Sheet1.AutoFilter.Range
        '// Set to somewhere blank and unused on your worksheet
        Set rCopy = Sheet1.Range("A" & Rows.Count - (.Rows.Count))
        .SpecialCells(xlCellTypeVisible).Copy rCopy
    End With

    With rCopy.Offset(1).Resize(5) '// Offset to avoid the header
        .Resize(, 2).Copy Sheet2.Range("A5")
        .Offset(, 3).Resize(, 1).Copy Sheet2.Range("D5")
        .Offset(, 5).Resize(, 1).Copy Sheet2.Range("F5")
        .CurrentRegion.Delete xlUp '// Delete the tempory area
    End With

    Set rCopy = Nothing

End Sub

Sub CopyTopFiveFromSpecificColumns()

    'set up the headers first to keep
    Dim rng_top5 As Range
    Set rng_top5 = Range("3:4").EntireRow

    Dim int_index As Integer
    'start below the headers and keep all the visible cells
    For Each cell In Intersect( _
        ActiveSheet.UsedRange.Offset(5), _
        Range("A:A").SpecialCells(xlCellTypeVisible))

        'add row to keepers
        Set rng_top5 = Union(rng_top5, cell.EntireRow)

        'track how many items have been stored
        int_index = int_index + 1
        If int_index >= 5 Then
            Exit For
        End If
    Next cell

    'copy only certain columns of the keepers
    Intersect(rng_top5, _
        Union(Range("A:A"), _
                Range("B:B"), _
                Range("D:D"), _
                Range("F:F"))).Copy

    'using Sheet2 here, you can set to wherever, works if data is not formulas
    Range("Sheet2!A1").PasteSpecial xlPasteAll

    'if the data contains formulas, use this route
    'Range("Sheet2!A1").PasteSpecial xlPasteValues
    'Range("Sheet2!A1").PasteSpecial xlPasteFormats

End Sub

Function GetTop5Range(SourceAddress As String) As Range
    Dim rngSource As Range
    Dim rngVisible As Range
    Dim rngIntersect As Range
    Dim rngTop5 As Range

    Dim i As Integer
    Dim cell As Range

    Set rngSource = Range(SourceAddress)
    Set rngVisible = rngSource.SpecialCells(xlCellTypeVisible).Cells
    Set rngIntersect = Intersect(rngVisible, rngVisible.Cells(1, 1).EntireColumn)

    i = 1
    For Each cell In rngIntersect
        If i = 1 Then
            Set rngTop5 = cell.EntireRow
            i = i + 1
        ElseIf i > 1 And i < 6 Then
            Set rngTop5 = Union(rngTop5, cell.EntireRow)
            i = i + 1
        Else
            Exit For
        End If
    Next cell

    Set GetTop5Range = Intersect(rngTop5, rngVisible)
End Function

Sub PasteRange(SourceRange As Range, TopLeftCornerRange As Range)
    Dim rngColumnRange As Range

    Dim cell As Range

    Set rngColumnRange = Intersect(SourceRange, SourceRange.Cells(1, 1).EntireRow)

    For Each cell In rngColumnRange
        Intersect(SourceRange, cell.EntireColumn).Copy
        TopLeftCornerRange.Offset(0, cell.Column - 1).PasteSpecial xlPasteValuesAndNumberFormats
    Next cell

    Application.CutCopyMode = False
End Sub

Sub Main()
    PasteRange GetTop5Range("A2:B33,D2:D33"), Range("A35")
End Sub