Sub dd()
Dim i As Long
Dim lr As Long
Dim rdel As Range
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
k = Application.WorksheetFunction.CountIf(Range(Cells(1, 6), Cells(lr, 6)), Cells(i, 6)) - _
(Application.WorksheetFunction.CountIfs(Range(Cells(1, 6), Cells(lr, 6)), Cells(i, 6), Range(Cells(1, 5), Cells(lr, 5)), "свекла") + _
 Application.WorksheetFunction.CountIfs(Range(Cells(1, 6), Cells(lr, 6)), Cells(i, 6), Range(Cells(1, 5), Cells(lr, 5)), "морковь"))
If k = 0 Then

If rdel Is Nothing Then
    Set rdel = Cells(i, 1)
Else
    Set rdel = Union(rdel, Cells(i, 1))
End If
End If
Next i
If Not rdel Is Nothing Then rdel.EntireRow.Delete
Application.ScreenUpdating = True
End Sub