VBA code takes very long time to execute - loops

Question

The following VBA code takes very long time to execute. I ran it 25 minutes ago for 48,000 rows and it's still running. How can I shorten the execution time?
Sub delrows()
Dim r, RowCount As Long
r = 2
ActiveSheet.Columns(1).Select
RowCount = UsedRange.Rows.Count
userresponse = MsgBox("You have " & RowCount & " rows", vbOKOnly, "Info")
Rows(RowCount).Delete Shift:=xlUp
' Trim spaces
Columns("A:A").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, searchFormat:=False, _
ReplaceFormat:=False
' Delete surplus columns
Range("L:T,V:AA,AE:AG,AR:AR,AU:AU,AZ:AZ").Select
Selection.Delete Shift:=xlToLeft
' Delete surplus rows
Do
If Left(Cells(r, 1), 1) = "D" _
Or Left(Cells(r, 1), 1) = "H" _
Or Left(Cells(r, 1), 1) = "I" _
Or Left(Cells(r, 1), 2) = "MD" _
Or Left(Cells(r, 1), 2) = "ND" _
Or Left(Cells(r, 1), 3) = "MSF" _
Or Left(Cells(r, 1), 5) = "MSGZZ" _
Or Len(Cells(r, 1)) = 5 _
Or Cells(r, 3) = 0 Then
Rows(r).Delete Shift:=xlUp
ElseIf Int(Right(Cells(r, 1), 4)) > 4000 Then
Rows(r).Delete Shift:=xlUp
Else: r = r + 1
End If
Loop Until (r = RowCount)
End Sub

Answer 1

The biggest issue is probably the amount of data you are looping through. I've updated your code to create a formula to check if the row needs to be deleted, then you can filter on that formula result and delete all rows at once.
I've made a bunch of comments to both help you clean your code and understand what I did. I prefaced my comments with '=>.
One last note, loading the values into an array may help as well, but if you have many, many columns of data, this may be more difficult. I don't have a ton of experience with it, but I know it makes things worlds faster!
Good luck and have fun!
Option Explicit
Sub delrows()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim r As Long, RowCount As Long
r = 2
Dim wks As Worksheet
Set wks = Sheets(1) '=> change to whatever sheet index (or name) you want
'=> rarely a need to select anything in VBA [ActiveSheet.Columns(1).Select]
With wks
RowCount = .Range("A" & .Rows.Count).End(xlUp).Row '=> as opposed to [RowCount = UsedRange.Rows.Count], as UsedRange can be misleading
'NOTE: this also assumes Col A will have your last data row, can move to another column
userresponse = MsgBox("You have " & RowCount & " rows", vbOKOnly, "Info")
.Rows(RowCount).Delete Shift:=xlUp
' Trim spaces
'=> rarely a need to select anything in VBA [Columns("A:A").Select]
.Range("A1:A" & RowCount).Replace What:=" ", Replacement:="", lookat:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, searchFormat:=False, _
ReplaceFormat:=False
' Delete surplus columns
'=> rarely a need to select anything in VBA [Range("L:T,V:AA,AE:AG,AR:AR,AU:AU,AZ:AZ").Select]
.Range("L:T,V:AA,AE:AG,AR:AR,AU:AU,AZ:AZ").Delete Shift:=xlToLeft ' as opposed to Selection.Delete Shift:=xlToLeft
' Delete surplus rows
'=> Now, here is where we help you loop:
'=> First insert column to the right to capture your data
.Columns(1).Insert Shift:=xlToRight
.Range("A1:A" & RowCount).FormulaR1C1 = "=If(OR(Left(RC[1],1) = ""D"",Left(RC[1],1) = ""H"", Left(RC[1],1) = ""I"", Left(RC[1],2) = ""MD"",Left(RC[1],2) = ""ND"",Left(RC[1],3) = ""MSF"",Left(RC[1],5) = ""MSGZZ"",Len(RC[1])=5),""DELETE"",If(Int(Right(RC[1],4)) > 4000,""DELETE"",""""),""""))"
'=> Now, assuming you something to delete ...
If Not .Columns(1).Find("DELETE", LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then
'=> filter and delete
.Range("A1:A" & RowCount).AutoFilter 1, "DELETE"
Intersect(.UsedRange, .UsedRange.Offset(1), .Range("A1:A" & RowCount)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
'=> Get rid of formula column
.Columns(1).EntireColumn.Delete
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Answer 2

the reason its so slow is you are iterating over each cell. Below copies to an array, finds the rows that need deleting and then deletes. Update Sheet4 to your sheet and Range("A2").CurrentRegion to the area you require:
Dim data() As Variant
Dim count As Double, i As Double, z As Double, arrayCount As Double
Dim deleteRowsFinal As Range
Dim deleteRows() As Double
Application.ScreenUpdating = False
data = Sheet4.Range("A2").CurrentRegion.Value2
For i = 1 To UBound(data, 1)
count = count + 1
If (data(i, 1) = "D" Or Left(data(i, 1), 1) = "H" Or Left(data(i, 1), 1) = "I" Or Left(data(i, 1), 2) = "MD" _
Or Left(data(i, 1), 2) = "ND" Or Left(data(i, 1), 3) = "MSF" Or Left(data(i, 1), 5) = "MSGZZ" _
Or Len(data(i, 1)) = 5 Or data(i, 3) = 0 Or Int(Right(IIf(Cells(i, 1) = vbNullString, 0, Cells(i, 1)), 4)) > 4000) Then
ReDim Preserve deleteRows(arrayCount)
deleteRows(UBound(deleteRows)) = count
arrayCount = arrayCount + 1
End If
Next i
Set deleteRowsFinal = Sheet4.Rows(deleteRows(0))
For z = 1 To UBound(deleteRows)
Set deleteRowsFinal = Union(deleteRowsFinal, Sheet4.Rows(deleteRows(z)))
Next z
deleteRowsFinal.Delete Shift:=xlUp
Application.ScreenUpdating = True

Answer 3

Turn off the screen updates to start with. Add your observations post the following.
You can disable calculations as well, if you think it isn't affecting anything as such.
Application.ScreenUpdating = False
your code...
Application.ScreenUpdating = True
EDIT: I have uploaded a file here - https://dl.dropbox.com/u/24702181/TestDeleteRowsInChunk.xls
The workbook is macro enabled.
After opening, click on "Recover Data" followed by "Start Deleting".
Take a look at the code for details. I suppose it can be optimized further.
A couple of hints
Do a reverse loop.
Get cell contents in an array, use array to check for values.
Build a string for rows to be deleted.
Delete it in chunks.