Search a column for a 1 and paste entire row to another worksheet when found?

Question

I am struggling with a bit of code that is getting stuck in a loop. I am trying to get the code to copy any rows where the values in column BD is 1 and paste the values for that entire row in to the next empty row in another worksheet. The code i am using is as below

Sub FindIssues()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
Sheets("Macro Worksheet").Select
If Range("BD" & i).Value = "1" Then Rows(i).Select
Selection.Copy
Sheets("Macro Worksheet 2").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

  Do Until IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
 Loop
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Sheets("Macro Worksheet").Select


Next i
End Sub

Thanks for your help

Answer 1

Macro Worksheet

Option Explicit

Sub CopyEntireRow()
Application.ScreenUpdating = False
    Dim src As Worksheet
    Set src = Sheets("Macro Worksheet")

    Dim trgt As Worksheet
    Set trgt = Sheets("Macro Worksheet 2")

    Dim i As Long
    For i = 1 To src.Range("A" & Rows.Count).End(xlUp).Row
        If src.Range("A" & i) = 1 Then
            ' calling the copy paste procedure
            CopyPaste src, i, trgt
        End If
    Next i
Application.ScreenUpdating = True
End Sub

' this sub copoes and pastes the entire row into a different sheet
' below the last used row
Private Sub CopyPaste(ByRef src As Worksheet, ByVal i As Long, ByRef trgt As Worksheet)
    src.Activate
    src.Rows(i & ":" & i).Copy
    trgt.Activate
    Dim nxtRow As Long
    nxtRow = trgt.Range("A" & Rows.Count).End(xlUp).Row + 1
    trgt.Rows(nxtRow & ":" & nxtRow).PasteSpecial _
        Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub

Macro Worksheet 2

Answer 2

I've replicated your 2 sheets with column A on Macro Worksheet containing

and column BD containing 1s in rows 3 and 5

So I expect rows 3 and 5 to copy to rows 1 and 2 of Macro Worksheet 2.

When I run FindIssues with a blank cell A1 selected on macro Worksheet I get the unexpected result of

If you look at and step through your code (reformatted and commented):

Option Explicit

Sub FindIssues()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
    Sheets("Macro Worksheet").Select

    'Select the i row if if BD = 1
    If Range("BD" & i).Value = "1" Then Rows(i).Select

    'else just copy the current selection
    Selection.Copy
    Sheets("Macro Worksheet 2").Select

    'then paste it into A1 on Macro Sheet 2
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'then find the first empty row on Macro Sheet 2
    Do Until IsEmpty(ActiveCell)
       ActiveCell.Offset(1, 0).Select
    Loop

    'and repaste the copied cells there
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Macro Worksheet").Select
Next i
End Sub

Stepping through the code, when i=2 BD is blank the currently selected A1 is copied to A1 and A2 on Macro Worksheet 2.

When i = 3 BD has a 1 in it so it gets copied to A1 on Macro Worksheet 2 and then pasted into A3 as well.

And so on it goes with each row having 1 in BD being copied once into A1 and then into the next empty row.

So you need to get rid of the code that copies into A1

    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

The other problem area is around

    If Range("BD" & i).Value = "1" Then Rows(i).Select

because IF BD doesn't equal 1, the code below your IF statement is executed anyway but it copies the selection from the prior iteration of the loop (i.e. the selection hasn't changed):

        'else just copy the current selection
    Selection.Copy
    Sheets("Macro Worksheet 2").Select

    'then find the first empty row on Macro Sheet 2
    Do Until IsEmpty(ActiveCell)
       ActiveCell.Offset(1, 0).Select
    Loop

    'and repaste the copied cells there
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

If you change your code to put those commands within the IF statement it looks like this

Sub FindIssues()
Dim LR As Long, i As Long
    LR = Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To LR
        Sheets("Macro Worksheet").Select

        'Select the i row if if BD = 1
        If Range("BD" & i).Value = "1" Then
            Rows(i).Select
            Selection.Copy
            Sheets("Macro Worksheet 2").Select

            'then find the first empty row on Macro Sheet 2
            Do Until IsEmpty(ActiveCell)
               ActiveCell.Offset(1, 0).Select
            Loop

            'and repaste the copied cells there
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            Sheets("Macro Worksheet").Select
        End If
    Next i
End Sub

It's probably a bit pedantic but it reduces the code lines

• avoid selecting objects in your code; it just slows things down!
• do copy/paste on one line of code

and this is one possible solution:

Sub FindIssues()
Dim LR As Long, i As Long
Dim LR2 As String
    LR = Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To LR

        'Test if BD equals 1
        If Range("BD" & i).Value = "1" Then

            'set the next row on Macro Worksheet 2 (assuming no blanks)
            LR2 = WorksheetFunction.CountA(Sheets("Macro Worksheet 2").Range("A:A")) + 1

            'copy row i to the destination
            Rows(i).Copy Sheets("Macro Worksheet 2").Range(LR2 & ":" & LR2)
        End If
    Next i
End Sub

Which gives this result On Macro Worksheet 2