Try:
Code:
Sub DeleteExcess()
Application.ScreenUpdating = False
Dim lRow As Long, cRow As Long
With ActiveSheet
lRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
For cRow = lRow To 5 Step -1
Select Case .Cells(cRow, 1).Value
Case 5000 To 5999, 7500 To 8299, 8400 To 9599, 9700 To 9999
.Cells(cRow, 1).EntireRow.Delete
Case Else
End Select
Next
End With
Application.ScreenUpdating = True
End Sub