=(счётесли($A$2:$A$999;$A2)>1)*(B2="")

Sub delete_()
For r = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
    If IsEmpty(Cells(r, 3)) Then
        If Not Range(Cells(r - 1, 1), Cells(2, 1)).Find(Cells(r, 1)) Is Nothing Then Rows(r).Delete
    End If
Next r
End Sub

Sub delete_2()
Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = vbTextCompare
ilr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To ilr
    Select Case oDict.exists(Cells(r, 1).Value)
        Case False
        oDict.Add Cells(r, 1).Value, Range(Cells(r, 1), Cells(r, 3))
        Case True
        Set rD = oDict.Item(Cells(r, 1).Value)
        If rD.Cells(2) > Cells(r, 2).Value Then oDict.Item(Cells(r, 1).Value) = Range(Cells(r, 1), Cells(r, 3))
    End Select
Next r
    Range("A2").Resize(oDict.Count, 3) = Application.Transpose(Application.Transpose(oDict.Items))
    Rows(oDict.Count + 2 & ":" & ilr).Delete
End Sub

Sub test()
Dim dic As Object, ikey
Dim i&, arr(), arr1$(), lrow&, x&
Set dic = CreateObject("scripting.dictionary")
With Лист1
    lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range(.[a2], .Cells(lrow, 3)).Value
    .Range(.[a2], .Cells(lrow, 3)).ClearContents
    For i = 1 To UBound(arr)
        If Not IsEmpty(arr(i, 3)) Then If dic.Item(CStr(arr(i, 1))) <= arr(i, 2) Then _
                dic.Item(CStr(arr(i, 1))) = arr(i, 2) & " " & arr(i, 3)
    Next i
    i = 0
    ReDim arr(1 To dic.Count, 1 To 3)
    For Each ikey In dic.keys
        i = i + 1: arr(i, 1) = ikey
        arr1 = Split(dic.Item(ikey), " ")
        For x = 2 To 3: arr(i, x) = arr1(x - 2): Next x
    Next ikey
    .[a2].Resize(UBound(arr), UBound(arr, 2)) = arr
End With
End Sub