Copy Rows with Certain Values

[edson.paula]

This is very good!
I need to do something similar, I need to copy the entire row and past the value to sheet1 if the value in column D is equal to "TestA" and to sheet2 if column D is equal to "TestB" and so on.
Can you help me?
Thank you!


Try this.

Sub Transfer_Ones_And_Twos()
Dim c As Range
For Each c In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If Right(c.Value, 1) = 1 Then c.Resize(, 3).Copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
If Right(c.Value, 1) = 2 Then c.Resize(, 3).Copy Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1)
Next c
End Sub

If you have a large range, this might be slightly faster. Change Sheet references as required.

Sub With_AutoFilter()
Dim lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
Columns("A:A").Insert Shift:=xlToRight
Range("A1").Value = "Temp"
Range("A2:A" & lr).Formula = "=RIGHT(RC[1], 1)"
With Columns("A")
.AutoFilter 1, 1
.Range("B2:D" & lr).Copy Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1)
.AutoFilter 1, 2
.Range("B2:D" & lr).Copy Sheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Offset(1)
.AutoFilter
End With
Columns("A").Delete
Application.ScreenUpdating = True
End Sub