Sorry for the delay.
Try this code -
Option Explicit
Sub delete_rows()
Dim lrow As Long, i As Long
Application.ScreenUpdating = False
With Worksheets("Sheet2")
'1st round of deletion
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("E:E") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A:F")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For i = lrow To 2 Step -1
If .Range("E" & i).Value <> .Range("E" & i - 1).Value Then
.Rows(i).Delete
Else
i = i - 1
End If
Next i
'2nd round of deletion
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("E:E") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=Range("A:A") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A:F")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For i = lrow To 2 Step -1
If .Range("E" & i).Value = .Range("E" & i - 1).Value And .Range("A" & i).Value <> .Range("A" & i - 1).Value Then .Rows(i & ":" & i - 1).Delete
Next i
'3rd round of deletion
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("E:E") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=Range("A:A") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=Range("B:B") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A:F")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For i = lrow To 2 Step -1
If .Range("E" & i).Value = .Range("E" & i - 1).Value And .Range("A" & i).Value = .Range("A" & i - 1).Value And _
.Range("B" & i).Value = .Range("B" & i - 1).Value Then .Rows(i & ":" & i - 1).Delete
Next i
End With
MsgBox "Deletion complete"
Application.ScreenUpdating = True
End Sub
Bookmarks