Question

我有一个数据表，按照F列的降序排序。然后我需要复制前5行，但只需复制A，B，D和F列（不是标题）的数据。见图片。

Sub top5()

Sheets("Sheet1").Select

If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If


ActiveSheet.Range("$A$4:$T$321").AutoFilter Field:=3, Criteria1:="Dave"
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields. _
    Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add _
    Key:=Range("F4:F321"), SortOn:=xlSortOnValues, Order:=xlDescending, _
    DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

' This copy-paste part does what its supposed to, but only for the specific 
' cells.  Its not generalised and I will have to repeat this operation
' several times for different people
Sheets("Sheet1").Select
Range("A3:B15").Select
Selection.Copy

Sheets("Sheet2").Select
Range("A3").Select
ActiveSheet.Paste

Sheets("Sheet1").Select
Range("D3:D15").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Sheet2").Select
Range("C3").Select
ActiveSheet.Paste

Sheets("Sheet1").Select
Range("F3:F15").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Sheet2").Select
Range("D3").Select
ActiveSheet.Paste
Application.CutCopyMode = False

End Sub

我想过尝试使用可见细胞功能调整下面的代码片段，但是我被困住了，我在网上找不到任何合适的东西。

' This selects all rows (plus 1, probably due to offset), I only want parts of from the top 5.
Sheets("Sheet1").Select
ActiveSheet.Range("$A$4:$B$321").Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A3").Select
ActiveSheet.Paste

Sheets("Sheet1").Select
ActiveSheet.Range("$D$4:$D$321").Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Sheet2").Select
Range("C3").Select
ActiveSheet.Paste

我希望我的榜样有道理，我非常感谢你的帮助！

Sample Excel table

注意：两个表中的标题名称相同，表明数据相同。标题不应该被复制。此外，第二个表中还有一个额外的列/空格。解决方案应该包括这个。

Data copied to new table

Answer 1

首先是一些有用的观点：

您应该参考Code Name处的工作表，以避免重命名问题。
如果您想与VBA合作，那么我的建议是避免像瘟疫这样的合并细胞。它们会对代码造成严重破坏。如果可能的话，使用格式单元格 - 对齐 - 水平 - 中心交叉选择
我也尽可能地建议avoiding loops并利用内置功能的excel作为一种良好的练习练习。

这是我的解决方案。把事情简单化。如果您需要进一步的帮助，请立即告诉我

row.Cells[1].Value

Answer 2

快速执行此操作的方法是使用Union和Intersect仅复制所需的单元格。如果要粘贴值（或者数据不是要启动的公式），这很有效。考虑到这一点，它构建了一系列列以继续使用Union，然后Intersect使用前5行数据和2个标题行。结果只是您希望格式完整的数据的副本。

仅编辑处理可见行，抓取标题，然后是标题行下方的前5行

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

以下是我从一些虚拟数据设置得到的结果，其范围与上图相同。

可复制范围的Sheet1

Sheet1

包含粘贴数据的Sheet2

Sheet2

Answer 3

问题的第一部分，选择top5可见单元格，相对容易，复制和粘贴就是问题所在。你看，你不能将范围粘贴到非均匀范围内，即使它不均匀。因此，您需要编写自己的粘贴功能。

第1部分 - 获取前5行

我对@ Byron使用了类似的技巧。请注意，这只是一个返回Range对象并接受String的函数，它代表您的非均匀范围（如果您愿意，可以将参数类型更改为Range。） / p>

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

第2部分 - 创建自己的粘贴功能

由于Excel始终将复制的范围粘贴为统一，因此您需要自己完成。此方法基本上将源区域分解为列并单独粘贴它们。该方法接受类型为Range的参数SourceRange（由Top5范围设计）和类型为Range的TopLeftCornerRange，它代表粘贴的目标单元格。

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

第3部分 - 运行程序

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

那就是它。

在我的项目中，我像你一样在A，B和D列中获得了源数据，结果被粘贴到从A35开始的范围。

结果：

enter image description here

希望这有帮助！

Answer 4

试试这个：

Sub GetTopFiveRows()
    Dim table As Range, cl As Range, cnt As Integer

    Set table = Worksheets("Sheet1").Range("A2:A10").SpecialCells(xlCellTypeVisible)
    cnt = 1

    With Worksheets("Sheet2")
        For Each cl In table
            If cnt <= 5 Then
                .Range("A" & cnt) = cl
                .Range("B" & cnt) = cl.Offset(0, 1)
                .Range("D" & cnt) = cl.Offset(0, 3)
                .Range("F" & cnt) = cl.Offset(0, 5)
                cnt = cnt + 1
            Else
                Exit Sub
            End If
        Next cl
    End With
End Sub

首先，引用仅设置为整个表中的可见行（您需要更新范围引用）
然后我们在可见范围内循环，复制到第2张，并在复制了5条记录（即前五条）时停止

Answer 5

虽然循环前五个可见行可能更容易，但我使用application.evaluate来处理返回第五个可见记录的行号的工作表样式公式。

Sub sort_filter_copy()
    Dim lr As Long, lc As Long, flr As Long, rws As Long, v As Long
    Dim sCRIT As String
    Dim vCOLs As Variant, vVALs As Variant
    Dim bCopyFormulas As Boolean, bSort2Keys As Boolean

    bCopyFormulas = True
    bSort2Keys = False
    sCRIT = "dave"
    vCOLs = Array(1, 2, 4, 6)

    With Sheet1
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        lc = .Cells(4, Columns.Count).End(xlToLeft).Column
        With .Cells(5, 1).Resize(lr - 4, lc)
            'sort on column F as if there was no header
            If bSort2Keys Then
                .Cells.Sort Key1:=.Columns(6), Order1:=xlDescending, _
                            Key2:=.Columns(7), Order2:=xlDescending, _
                            Orientation:=xlTopToBottom, Header:=xlNo
            Else
                .Cells.Sort Key1:=.Columns(6), Order1:=xlDescending, _
                            Orientation:=xlTopToBottom, Header:=xlNo
            End If
            With .Offset(-1, 0).Resize(.Rows.Count + 1, .Columns.Count)
                .AutoFilter
                .AutoFilter field:=3, Criteria1:=sCRIT
                With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
                    rws = Application.Min(5, Application.Subtotal(103, .Columns(3)))
                    If CBool(rws) Then
                        flr = Application.Evaluate("=small(index(rows(5:" & lr & ") + ('" & Sheet1.Name & "'!C5:C" & lr & "<>" & Chr(34) & sCRIT & Chr(34) & ")*1e99, , ), " & rws & ")")
                        For v = LBound(vCOLs) To UBound(vCOLs)
                            If .Columns(vCOLs(v)).Cells(1).HasFormula And bCopyFormulas Then
                                Sheet2.Cells(3, vCOLs(v)).Resize(5, 1).FormulaR1C1 = _
                                    .Columns(vCOLs(v)).Cells(1).FormulaR1C1
                            Else
                                .Columns(vCOLs(v)).Resize(flr - 4, 1).Copy _
                                    Destination:=Sheet2.Cells(3, vCOLs(v))
                            End If
                        Next v
                    End If
                End With
                .AutoFilter
            End With
            'uncomment the next line if you want to return to a standard ascending sort on column A
            '.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlNo
        End With
    End With
End Sub

所有选项都设置在变量声明的正下方。您的示例图像似乎表明您使用了两种密钥排序，因此我可以选择编码。如果你想引入任何公式作为公式，那就是那个选项。过滤条件和要复制的列也分配给各自的变量。

Sort, Filter and Copy Top 5

我的公共DropBox上提供了我的示例工作簿：
Sort_Filter_Copy_from_Top_5.xlsb

Answer 6

首先取消合并单元格，然后使用此代码，与其他一些建议非常相似。

    Sub Button1_Click()
    Dim sh As Worksheet
    Dim Rws As Long, Rng As Range, fRng As Range, c As Range, fRw As Long

    Set sh = Sheets("Sheet2")
    Rws = Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Range(Cells(4, 1), Cells(Rws, "T"))    'unmerge all the headers


    Rng.AutoFilter Field:=3, Criteria1:="Dave"
    ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields. _
            Clear
    ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add _
            Key:=Range("F4:F321"), SortOn:=xlSortOnValues, Order:=xlDescending, _
            DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Set fRng = Range(Cells(5, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeVisible)
    x = 0

    For Each c In fRng.Cells

        If x = 5 Then Exit Sub
        fRw = sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
        sh.Range(sh.Cells(fRw, 1), sh.Cells(fRw, 2)).Value = Range(Cells(c.Row, 1), Cells(c.Row, 2)).Value
        sh.Cells(fRw, 4).Value = Cells(c.Row, 4).Value
        sh.Cells(fRw, 6).Value = Cells(c.Row, 6).Value
        x = x + 1

    Next c
End Sub

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

6 个答案: