VBA code takes very long time to execute

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

Solution 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

Solution 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

Solution 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.

Comments

[brettdj]

You should either use a variant array or a humble IF test (manually or with VBA) that can be used with AutoFilter to delete rows meeting the specified condition. Never use range loops - but if you do, delete bottom up to avoid skipping rows

[K_B]

ALWAYS Dim every variable, to be sure you do use Option Explicit in each program as well. Set this by default by going to Tools > Options > (tick) Require Variable Declaration. Also Dim A, B as Integer will dimension A as Variant or Object, you will have to state the type for EACH variable separately!

[K_B]

Furthermore if I am not mistaken VBA doesnt short-circuit, thus all comparisons in the IF statement with the Or ... Or ... Or will be considered. Maybe consider a Case Select instead and refer to a different Sub with the code for all those cases...

[Mehper C. Palavuzlar]

Still taking too long... I think the code is not productive at some point or the design is problematic.

[shahkalpesh]

What part of code is taking long time? Can you share the workbook with dummy data in it on which this macro can be run? Is it possible for you to identify row numbers that should be deleted and delete it all at once instead of deleting it one by one?

[Mehper C. Palavuzlar]

I broke the code and checked the sheet just to see every condition in the code is fulfilled. When I debug, it jumps on END IF line. I think the code is running in the loop superfluously. Maybe Loop Until (r = RowCount) is the problem. Anyway, your suggestion in your comment (identify row numbers and delete them all once) seems perfect. How can I do that?

[shahkalpesh]

@MehperC.Palavuzlar: Please see my edits and download the file from the link. Take a look at the VBA code, that should give you hints esp. on chunking the row deletion.

[shahkalpesh]

Mehper: How does this solution compare in terms of time it takes to delete rows vis-a-vis existing code and other suggestions added above?