Sub test()
Dim DropRows As Range, WRow As Range, I As Long, N As Long
With ActiveSheet
  .Columns("A:A").AutoFit
  If .AutoFilterMode Then .AutoFilterMode = False
  Worksheets("Лист2").Columns( 1 ).Delete
  .Range("A1:A" & .Range("A65536").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, _
    Unique:=True, CopyToRange:=Worksheets("Лист2").Range("A1")
  Set DropRows = .Rows( 65536 )
  For I =  2  To Worksheets("Лист2").Range("A65536").End(xlUp).Row
    .Range("A:A").AutoFilter Field:= 1 , Criteria1:=Worksheets("Лист2").Cells(I,  1 ), _
      VisibleDropDown:=False
    N =  1 
    For Each WRow In .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows
      If N =  1  Then
        N = WRow.Row
      Else
        If Cells(N,  2 ) > Cells(WRow.Row,  2 ) Then
          Set DropRows = Union(DropRows, Cells(N,  2 ).EntireRow)
          N = WRow.Row
        Else
          Set DropRows = Union(DropRows, WRow)
        End If
      End If
    Next WRow
    If .AutoFilterMode Then .AutoFilterMode = False
  Next I
  If .AutoFilterMode Then .AutoFilterMode = False
  DropRows.EntireRow.Delete
  .Range("A1").Select
End With
End Sub