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