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