Copy only selected rows

[harry211]

Hi!
My macro looks like this:

Sub copydata ()
Sheets ("Template"). Select
lr = Cells.Find ("*", Cells (1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False) .Row
Range ("A3: R" & lr) .Copy
Sheets ("List"). Select
lrTarget = Cells.Find ("*", Cells (1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False) .Row
Cells (lrTarget + 1, 1) .Select
Selection.PasteSpecial Paste: = xlPasteValues, Operation: = xlNone, SkipBlanks _
: = False, Transpose: = False
End Sub

It works fine with copying all lines to the "List" tab. I need to modify the code, which will copy only those rows where in the R column (the "STATUS" column) the status is "Done".

Thanks in advance for any help!
J.

 

[kevin9999]

One more thing, I need to paste values only

Try this Harry:

Option Explicit
Sub harry211_V4()
    Dim ws1 As Worksheet, ws2 As Worksheet, lr As Long
    Set ws1 = Sheets("Template")
    Set ws2 = Sheets("List")
    lr = ws2.Cells(Rows.Count, 1).End(3).Row
    If lr = 1 Then lr = 2
    
    With ws1.Range("A2").CurrentRegion
        .Columns.Hidden = False
        .AutoFilter 18, "Done"
        .Offset(1).Resize(.Rows.Count - 1).Copy
            ws2.Range("A" & lr).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        .AutoFilter
    End With
    ws1.Range("C:F").EntireColumn.Hidden = True
End Sub

 

[harry211]

One more thing, I need to paste values only

Glad to help

oh and one last thing. The code overwrites the last row instead of pasting the data into the first free one

 

[kevin9999]

oh and one last thing. The code overwrites the last row instead of pasting the data into the first free one

Option Explicit
Sub harry211_V5()
    Dim ws1 As Worksheet, ws2 As Worksheet, lr As Long
    Set ws1 = Sheets("Template")
    Set ws2 = Sheets("List")
    lr = ws2.Cells(Rows.Count, 1).End(3).Row
    'If lr = 1 Then lr = 2
    
    With ws1.Range("A2").CurrentRegion
        .Columns.Hidden = False
        .AutoFilter 18, "Done"
        .Offset(1).Resize(.Rows.Count - 1).Copy
            ws2.Range("A" & lr + 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        .AutoFilter
    End With
    ws1.Range("C:F").EntireColumn.Hidden = True
End Sub