Copying the matched row in another sheet

问题

I have two Sheets, sheet1 and sheet 2. I am looking into column T of sheet1 and pasting the complete row if T contains 1 in sheet 2. The code, works good, but it paste the result in sheet2 in the same row in sheet1. This results in blanks, between the rows. Can anyone suggest, what i should Change with my code, so that i get them in sequence without any blank rows. Also, how can I copy the Header in row 1 from sheet 1 to 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

回答1:

There's no need to use Select and Selection to copy paste, it will only slows down your code's run-time.

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

回答2:

Not For Points

Apologies, but I couldn't stop myself from posting an answer. It pains me when I see someone wanting to use an inferior way of doing something :(

I am not in favor of looping. It is very slow as compared to Autofilter.

If you STILL want to use looping then you can make it faster by not copying the rows in the loop but in the end in ONE GO...

Also if you do not like living dangerously then always fully qualify your object else you may end up copying the wrong row.

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

Screenshot

来源：https://stackoverflow.com/questions/44774795/copying-the-matched-row-in-another-sheet