Try this code
Sub Test()
Dim a As Variant
Dim b As Variant
Dim r As Range
Dim i As Long
Application.ScreenUpdating = False
With Cells(1).CurrentRegion.Resize(, 3)
.Offset(1).Columns(3).ClearContents
a = .Value
ReDim b(1 To UBound(a, 1) - 1, 1 To 1)
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .Exists(a(i, 1)) Then
Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
End If
.Item(a(i, 1))(a(i, 2)) = Empty
Next i
For i = 2 To UBound(a, 1)
b(i - 1, 1) = .Item(a(i, 1)).Count
Next i
End With
For i = 2 To UBound(a, 1)
If a(i, 2) <> 0 Or b(i - 1, 1) > 1 Then
If r Is Nothing Then Set r = Cells(i, 1) Else Set r = Union(r, Cells(i, 1))
End If
Next i
If Not r Is Nothing Then r.EntireRow.Delete
End With
Application.ScreenUpdating = False
End Sub