Delete lines VBA macro takes a significant amount

Question

I have a macro that deletes lines based on a certain value in a column and then sorts them. It works fine. However, the worksheet starts with about 4000 rows and the macro ends up deleting about 2000 of them and it takes 1 minute 25 seconds to do it. I'm wondering if there's something I can do that will make it take a lot less time. Here's the code:

'remove numbers that are not allowed based on values in "LimitedElements" worksheet

For i = imax To 1 Step -1
    a = Sheets("FatigueResults").Cells(i, 1).Value
    Set b = Sheets("LimitedElements").Range("A:A")
    Set c = b.Find(What:=a, LookIn:=xlValues)

    If Not c Is Nothing Then
        Sheets("FatigueResults").Rows(i).EntireRow.Delete
    End If
Next i

'delete unecessary or redundant rows and columns
Rows(3).EntireRow.Delete
Rows(1).EntireRow.Delete
Columns(23).EntireColumn.Delete
Columns(22).EntireColumn.Delete
Columns(21).EntireColumn.Delete
Columns(20).EntireColumn.Delete
Columns(14).EntireColumn.Delete
Columns(13).EntireColumn.Delete
Columns(12).EntireColumn.Delete
Columns(11).EntireColumn.Delete
Columns(4).EntireColumn.Delete
Columns(3).EntireColumn.Delete
Columns(2).EntireColumn.Delete

'sort data
    Dim strDataRange As Range
    Dim keyRange As Range

    Set strDataRange = Range("A:Q")
    Set keyRange1 = Range("B1")
    Set keyRange2 = Range("G1")
    strDataRange.sort Key1:=keyRange1, Order1:=xlDescending,     Key2:=keyRange2, Order2:=xlDescending, Header:=xlYes

'delete rows that are not in the included values    For i = imax To 2 Step -1

    If (Cells(i, 2).Value <> 0.04 And Cells(i, 2).Value <> 0.045 And Cells(i, 2).Value <> 0.05 And Cells(i, 2).Value <> 0.056 And Cells(i, 2).Value <> 0.063 And Cells(i, 2).Value <> 0.071 And Cells(i, 2).Value <> 0.08 And Cells(i, 2).Value <> 0.09 Or Cells(i, 3).Value <= 0) Then

        ActiveSheet.Rows(i).EntireRow.Delete

    End If

Next i

Answer 1

Add this at the beginning:

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Add this at the end:

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

Also, instead of

If (Cells(i, 2).Value <> 0.04 And Cells(i, 2).Value <> 0.045 And Cells(i, 2).Value <> 0.05 And Cells(i, 2).Value <> 0.056 And Cells(i, 2).Value <> 0.063 And Cells(i, 2).Value <> 0.071 And Cells(i, 2).Value <> 0.08 And Cells(i, 2).Value <> 0.09 Or Cells(i, 3).Value <= 0) Then

    ActiveSheet.Rows(i).EntireRow.Delete

End If

Use

Select Case Cells(i, 2)
Case 0.4, 0.045, 0.05, 0.056, 0.063, 0.071, 0.08, 0.09, Is < 0
    'Do nothing
Case Else
    ActiveSheet.Rows(i).EntireRow.Delete
End Select

Answer 2

I much prefer to build a string of rows to be deleted then do ONE delete. Here is a sample I put together for another post on here yesterday:

Sub DeleteRows()
Dim i As Long, DelRange As String
For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row 'Doesn't matter which way you go when you delete in one go
    If Left(Cells(i, 6), 3) = "314" Then DelRange = DelRange & "," & i & ":" & i 'Change the "314" as you see fit
Next i
Range(Right(DelRange, Len(DelRange) - 1)).Delete
End Sub

Also no need to worry about turning calculation or screen updating etc off when you only perform one deletion