在另一个工作表中复制匹配的行

我有两个工作表，Sheet1和Sheet2。我正在查看Sheet1的T列，并粘贴完整的行，如果T在工作表2中包含1的话。代码工作正常，但它将工作表2的结果粘贴到工作表Sheet1的同一行。 这导致行之间的空白。 任何人都可以build议，我应该改变我的代码，以便我顺序没有任何空白行。 另外，我怎样才能将第1行的表头复制到Sheet2？

Sub Test() For Each Cell In Sheets(1).Range("T:T") If Cell.Value = "1" Then matchRow = Cell.Row Rows(matchRow & ":" & matchRow).Select Selection.Copy Sheets(2).Select ActiveSheet.Rows(matchRow).Select ActiveSheet.Paste Sheets(1).Select End If Next End Sub 

Answer 1

没有必要使用Select和Selection来复制粘贴，它只会减慢你的代码的运行时间。

 Option Explicit Sub Test() Dim Cell As Range Dim NextRow as Long Application.ScreenUpdating = False For Each Cell In Sheets(1).Range("T1:T" & Sheets(1).Cells(Sheets(1).Rows.Count, "T").End(xlUp).Row) If Cell.Value = "1" Then NextRow = Sheets(2).Cells(Sheets(2).Rows.Count, "T").End(xlUp).Row Rows(Cell.Row).Copy Destination:=Sheets(2).Range("A" & NextRow + 1) End If Next Application.ScreenUpdating = True End Sub 

Answer 2

不适用于积分

道歉，但我无法阻止自己发布答案。 当我看到有人想用劣势的做某事:(

我不赞成循环。 与Autofilter相比，速度非常慢。

如果你仍然想使用循环，那么你可以通过不复制循环中的行，但最终在一个去 … …使速度更快…

另外，如果你不喜欢危险的生活，那么总是完全限定你的对象，否则你可能会复制错误的行。

 Option Explicit Sub Sample() Dim wsI As Worksheet, wsO As Worksheet Dim lRow As Long, i As Long, r As Long Dim copyRng As Range Set wsI = Sheet1: Set wsO = Sheet2 wsO.Cells.Clear '~~> first available row in sheet2 r = 2 With wsI lRow = .Range("T" & .Rows.Count).End(xlUp).Row '~~> Copy Headers .Rows(1).Copy wsO.Rows(1) For i = 1 To lRow If .Range("T" & i).Value = 1 Then If copyRng Is Nothing Then Set copyRng = .Rows(i) Else Set copyRng = Union(copyRng, .Rows(i)) End If End If Next i End With If Not copyRng Is Nothing Then copyRng.Copy wsO.Rows(r) End Sub 

截图