Sub dsd3434()
Dim i As Long, lr As Long, cell As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
    For i = lr To 4 Step -1
        x = Left(Cells(i, 1), InStr(1, Cells(i, 1), "/") - 2)
    If Application.WorksheetFunction.CountIfs(Range(Cells(i, 1), Cells(lr, 1)), "*" & x & "*", Range(Cells(i, 2), Cells(lr, 2)), Cells(i, 2)) > 1 Then
        If cell Is Nothing Then
            Set cell = Cells(i, 1)
        Else
            Set cell = Union(cell, Cells(i, 1))
        End If
    End If
    Next i
If Not cell Is Nothing Then cell.EntireRow.Delete
End Sub