Maybe:
Sub Witebutter()
Dim lr As Long
Dim rcell As Range
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
'On sheet1
Columns("C:C").Insert SHIFT:=xlToRight
With Range("D2:D" & lr)
.Formula = "=VLOOKUP(C2,Sheet2!$C$2:$C$1000,1,FALSE)"
.Value = .Value
.Replace What:="#N/A", Replacement:="", LookAt:=xlWhole
End With
Columns("F:F").Insert SHIFT:=xlToRight
With Range("F2:F" & lr)
.Formula = "=VLOOKUP(E2,Sheet2!$D$2:$D$1000,1,FALSE)"
.Value = .Value
.Replace What:="#N/A", Replacement:="", LookAt:=xlWhole
End With
For Each rcell In Range("D2:D" & lr)
If rcell.Value <> "" Then
If rcell.Offset(, 2) <> "" Then
rcell.EntireRow.Copy Sheets("Sheet3").Range("A" & Rows.Count).End(3)(2)
End If
End If
Next rcell
Application.ScreenUpdating = True
End Sub
Bookmarks