[vba]

Private Sub DeleteRanges()
Dim Rng As Range, i As Long, r As Range, lVal, uVal
Dim DeleteCount As Double
Dim lRow As Long
Dim dr As Long
Dim dc As Long

With Sheets("Deleted Numbers")

dc = .Cells(2, Columns.Count).End(xlToLeft).Column - 1
dr = .Cells(Rows.Count, dc).End(xlUp).Row + 1
End With

If dr = 60001 Then
dr = 2
dc = dc + 2
End If

With Worksheets("TempRange")

lVal = .Range("A1").Value
uVal = .Range("B1").Value
End With

If lVal > uVal Then

MsgBox "End number must be greater than start number"
Exit Sub
End If

Application.StatusBar = "Deleting, please wait....!"
Application.ScreenUpdating = False

For i = 1 To Sheets.Count

With Sheets(i)

If .Name = "DATA" And _
.ProtectContents = False Then

Set Rng = .Range("A1", .Range("A1").SpecialCells(xlCellTypeLastCell))
For Each r In Rng

If r >= lVal And r <= uVal Then

With Sheets("Deleted Numbers")

.Cells(dr, dc).Value = r.Value
.Cells(dr, dc + 1).Value = Now
End With

If dr = 60000 Then

dr = 2
dc = dc + 2
Else

dr = dr + 1
End If

r.Clear
DeleteCount = DeleteCount + 1
End If
Next

On Error Resume Next
Rng.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
On Error GoTo 0
Set Rng = Nothing
End If
End With
Next

Application.ScreenUpdating = True

If DeleteCount = 0 Then

MsgBox "No Numbers Deleted"
Else

MsgBox DeleteCount & " numbers were deleted"
End If

Application.StatusBar = ""
End Sub
[/vba]