Option Explicit
Sub Cars()
Dim w1 As Worksheet, w2 As Worksheet
Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")
w1.Range("A1:E1").Copy w2.Range("A1")
Dim i As Long
Dim lr As Long
Dim lr2 As Long
lr = w1.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To lr
lr2 = w2.Range("A" & Rows.Count).End(xlUp).Row
If w1.Range("A" & i) = "Car" Then
If Not IsNull(w1.Range("E" & i)) Then
w1.Range("A" & i & ":E" & i).Cut w2.Range("A" & lr2 + 1)
End If
End If
Next i
For i = lr To 1 Step -1
If w1.Range("A" & i) = "" Then
w1.Range("A" & i).EntireRow.Delete
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "complete"
End Sub
Bookmarks