Transferring rows into another sheet

Question

I am trying to transfer two rows of Sheet1 (randomly and based on certain criteria) into Sheet3.

The values in cells "P2" and "P5" indicate the row number to be transferred, and column "A" has row numbers.

There's no possibility that values in "P2" and "P5" could match multiple rows in column "A". They should match 1 row each, so only one row should be copied per "P2" and "P5". Yet, sometimes I see multiple rows getting copied.

Below is the code:

Sub copyrows()

    Dim tfRow As Range, cell As Object

    Set tfRow = Range("A1:A") 'Range which includes the values

    For Each cell In tfRow

        If IsEmpty(cell) Then
        Exit Sub
        End If

        If cell.Value = Range("P2").Value Then
        cell.EntireRow.Copy
        Sheet3.Select  'Target sheet
        ActiveSheet.Range("A65536").End(xlUp).Select
        Selection.Offset(1, 0).Select
        ActiveSheet.Paste
        End If

    Next
End Sub


Sub copyrows2()

    Dim tfRow2 As Range, cell As Object

    Set tfRow2 = Range("A1:A") 'Range which includes the values

    For Each cell In tfRow2

        If IsEmpty(cell) Then
        Exit Sub
        End If

         If cell.Value = Range("P5").Value Then
        cell.EntireRow.Copy
        Sheet3.Select  'Target sheet
        ActiveSheet.Range("A65536").End(xlUp).Select
        Selection.Offset(1, 0).Select
        ActiveSheet.Paste
        End If

    Next
End Sub

user_6344363 · Answer

As @urdearboy mentioned in the commnets above, you need to add a row to your second A column range to avoid getting the error.

To merge two conditions, in your case add an Or to your If.

To run the code faster, don't Select and Activate different sheets, it takes a long time for the code to run. Instead, use a Range object, like CopyRng and every time the if criteria is ok, you add that cell to the range using the Union function. Read HERE about the Union functionality.

More comments inside the code's notes below.

Modified Code

Option Explicit

Sub copyrows()

Dim Sht1 As Worksheet, Sht3 As Worksheet
Dim tfRow As Range, C As Range ' use Range not Object, also try not to use Cell it's close to Cells
Dim CopyRng As Range
Dim LastRow As Long

Set Sht1 = Sheet1
Set Sht3 = Sheet3

With Sht1
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column A

    Set tfRow = .Range("A1:A" & LastRow) 'Range which includes the values

    For Each C In tfRow

        If IsEmpty(C) Then
            Exit Sub
        End If

        If C.Value = .Range("P2").Value Or C.Value = .Range("P5").Value Then ' use Or to combine both scenarios
            If Not CopyRng Is Nothing Then
                Set CopyRng = Application.Union(CopyRng, C)  ' use Union to merge multiple ranges
            Else
                Set CopyRng = C
            End If
        End If

    Next C
End With

' make sure there is at least one cells in your merged range
If Not CopyRng Is Nothing Then
    ' get last row with data in "sheet3"
    LastRow = Sht3.Cells(Sht3.Rows.Count, "A").End(xlUp).Row

    CopyRng.EntireRow.Copy Destination:=Sht3.Range("A" & LastRow + 1)
End If

End Sub

Transferring rows into another sheet

1 Answers