Option Explicit
Sub DelDups()
Dim intEnd As Long
Dim intRow As Long
Dim intColumn As Long
Dim i As Integer
' Turn off screen updating so we don't see all of the "flashing" as the sheet is being worked on
'Application.ScreenUpdating = False
intEnd = Application.CountA(ActiveSheet.Range("A:A")) 'Get the total number of rows used
intRow = 4
intColumn = 1
For i = 1 To 6 ' Loop through 6 times, just to be sure we get all of the duplicate entries
For intRow = 4 To intEnd
Rows(intRow).Select
' If the value of one cell is = to the value of the cell above it...
While Cells(intRow, intColumn) = Cells(intRow + 1, intColumn)
' If the value of the cell in column H is < or = to the one above it...
If Cells(intRow, 8) <= Cells(intRow + 1, 8) Then
' Select the row...
Rows(intRow).Select
' And delete it!!
Selection.Delete
Else
' Select the row...
Rows(intRow + 1).Select
' And delete it!!
Selection.Delete
End If
' Increase the row counter by 1
'intRow = intRow + 1
Wend
Next intRow
Next i
' Turn on screen updating
Application.ScreenUpdating = True
MsgBox "All Done"
End Sub
OK, I had to take into account if row+1 was > row, so it was freezing at the first instance of said problem. I added the else statement to delete r+1 and it flew throught the rest of the SS