Sub So()
Dim arr, x, z, del
arr = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Value
For x = LBound(arr, 1) + 1 To UBound(arr, 1) - 1
z = x + 1
Do While arr(z, 1) = arr(x, 1) And z < UBound(arr, 1)
del = del & Format(z, " 0")
x = z
z = z + 1
Loop
Next x
If arr(x, 1) = arr(x - 1, 1) Then del = del & Format(x, " 0")
If Len(del) = 0 Then Exit Sub
arr = Split(Trim(del), " ")
Application.ScreenUpdating = False
For x = UBound(arr) To LBound(arr) Step -1
Rows(arr(x)).Delete
Next x
Application.ScreenUpdating = True
End Sub