Copy row based on cell value

Question

I am trying to search within a specific column for a "yes" value and copy the entire row of data if present into a new sheet.

So far I copy and paste a row which doesn't include a "yes". This results in four rows of the same data pasted instead of the four I need.

Dim rng As Range, cell As Range

Dim sht As Worksheet
Set sht = Worksheets("Output")

With sht
    lastRow = .Range("R" & .Rows.Count).End(xlUp).Row
End With

If lastRow < 2 Then lastRow = 2

Set rng = sht.Range("R2:R" & lastRow)

For Each cell In rng
    If cell.Value = "Yes" Then
        ActiveCell.EntireRow.Copy
        Worksheets("Callouts").Activate
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
        ActiveCell.PasteSpecial Paste:=xlPasteValues
    End If
Next
End Sub

Answer 1

First you want iterate through each row, then each cell in the row to find the "Yes". Then you want to copy the row to the new sheet. Consider:

Dim rng As Range, cell As Range
Dim targetLastRow as Range

Dim sht As Worksheet
Set sht = Worksheets("Output")    

'capture last row in source
sourceLastRow = sht.Range("R" & Rows.Count).End(xlUp).Row   
If sourceLastRow < 2 Then sourceLastRow = 2

'set source rng
Set rng = sht.Range("R2:R" & lastRow)


'Capture last row in target sheet
targetLastRow = Sheets("Callouts").Range("A" & Rows.Count).End(xlUp).Row

'iterate through each row in source range
For each row in rng.rows 
    'iterate through each cell in row
    For Each cell In row
        If cell.Value = "Yes" Then
            cell.EntireRow.Copy 
            Sheets("Callouts").Cells(targetLastRow, 1).PasteSpecial Paste:=xlPasteValues
            'increment target to next row 
            targetLastRow = targetLastRow + 1
        End If
    Next
Next