Excel VBA：从前5行/单元过滤和复制

我有一个数据表在F列降序sorting。然后我需要复制前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 

我想过使用可见单元格function来调整下面的代码片段，但是我卡住了，我找不到适合的networking上的任何东西。

 ' 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 

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

注意：两个表中的标题名称只是相同的，以显示数据是相同的。 标题不应该被复制。 另外，第二个表中还有一个额外的列/空格。 解决scheme应包括这一点。

Answer 1

首先有一些有用的观点：

• 您应该通过代码名称参考工作表以避免重命名问题。
• 如果你想与VBA合作，那么我的build议是避免像鼠疫这样的合并细胞。 他们造成破坏代码。 如果可能，使用格式单元格 – alignment – 水平 – 中心交叉select
• 我也build议尽可能避免循环，并利用function上的优势，而不是一个很好的练习。

这是我的解决scheme。 把事情简单化。 如果你需要进一步的帮助，现在就让我。

 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 

Answer 2

一个快速的方法是使用Union和Intersect来只复制你想要的单元格。 如果你正在粘贴值（或者数据不是开始的公式），这个效果很好。 考虑一下，它build立了一系列的列来继续使用Union ，然后用前面的5行数据与2个标题行Intersect 。 结果是只有你想要的格式完整的数据的副本。

编辑只处理可见的行，抓住标题，然后在标题行下面的前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的复制范围可见

Sheet2粘贴数据

Answer 3

你的问题的第一部分，selecttop5可见单元格，是相对容易的，复制和粘贴是麻烦的地方。 你看，你不能把一个范围，即使它不统一，粘贴到不一致的范围。 所以你需要编写自己的粘贴function。

第1部分 – 获得Top5行

我使用了类似于@ Byron的技术。 请注意，这只是一个函数，返回一个Range对象并接受一个表示不一致范围的String （如果需要，可以将参数types更改为Range ）。

 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部分 – 创build您自己的粘贴function

由于Excel始终将复制的范围粘贴为统一格式，因此您需要自行完成。 这种方法基本上将你的源地区分解成列并分别粘贴。 该方法接受参数SourceRangetypesRange ，这意味着你的Top5范围，和一个typesRange的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开始的范围。

结果：

希望这可以帮助！

Answer 4

虽然循环前五个可见行可能会更简单，但我使用application.evaluate来处理返回第五个可见logging行号的工作表式公式。

 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 

所有选项都设置在variables声明的下方。 你的示例图像似乎表明，你使用了一个两键sorting，所以我编码的可选。 如果你想引入任何公式作为公式，那个选项就在那里。 筛选条件和要复制的列也分配给各自的variables。

我的示例工作簿可在我的公共DropBox中find：
Sort_Filter_Copy_from_Top_5.xlsb

Answer 5

尝试这个：

 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个logging（即前五个）被复制

Answer 6

首先取消合并单元格然后使用这个代码，非常类似于其他一些build议。

  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