VBA Code runs for a very long time

[kapsikum]

Hello Fellow community members!

This is a query related to VBA code optimisation and I am a beginner so I do not have much experience in this area. I am currently working on an excel file for building a dashboard and it required cleaning the data in the spreadsheet. So I wrote a very simple VBA code that successfully works but it takes an unusual amount of time to execute (40-45 mins). I researched on the internet regarding this but couldnt find a solution. I would be very happy if someone could help me with optimising the VBA code that I have created (posted below) so that it takes hopefully a maximum of 5 or 10 mins to execute or even faster. The code is simple where it deletes the entire row if the given criteria is matched in the specified range in a column. Thank you in advance for your help and I will be very grateful as I am a student working on this project!

VBA Code:

Sub Dashboard()
Application.ScreenUpdating = False
    Dim rng As Range, i As Integer
 
   'Set range to evaluate
     Set rng = Range("N8:N10000")

     'Loop backwards through the rows in the range to evaluate
     For i = rng.Rows.Count To 1 Step -1
  
             'If cell i in the range contains "x", delete the entire row
             If rng.Cells(i).Value = "John" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete name Tom
     Set rng = Range("L8:L10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "TOM" Then rng.Cells(i).EntireRow.Delete
     Next

     'Delete Blanks
     Set rng = Range("L8:L10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
     Next
   
           
     'Delete Blanks
     Set rng = Range("O8:O10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete Blanks
     Set rng = Range("Q8:Q10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete Blanks
     Set rng = Range("R8:R10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete Sara
     Set rng = Range("R8:R10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "SARA" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete Ben
     Set rng = Range("R8:R10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "BEN" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete Meredith
     Set rng = Range("R8:R10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "MEREDITH" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete April
     Set rng = Range("R8:R10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "APRIL" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete Jason
     Set rng = Range("R8:R10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "JASON" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete Sana
     Set rng = Range("R8:R10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "SANA" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete Blanks
     Set rng = Range("AJ8:AJ10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete June
     Set rng = Range("AJ8:AJ10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "JUNE" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete October
     Set rng = Range("AJ8:AJ10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "OCTOBER" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete January
     Set rng = Range("AJ8:AJ10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "JANUARY" Then rng.Cells(i).EntireRow.Delete
     Next
   
     'Delete Blanks
     Set rng = Range("AS8:AS10000")
     For i = rng.Rows.Count To 1 Step -1
     If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
     Next
     Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

I would be interested to know how it performs on your full data set.

Hi Alex, I have a few comments.

• For my sample data (may not be realistic) your code took about 8 times as long as mine (though it did not produce quite the same results*). Still pretty fast though at a little over 1 second.
• For this exercise, I think using CurrentRegion is risky. Although this analysis is to start on row 8, it would not be unusual for there to be something (headings, summary, formulas etc) above that and CurrentRegion could easily include rows above row 8. If any of those rows meet any of the deletion criteria - quite likely given the number of 'blank' tests - then they will be (incorrectly) deleted.
• Your method of deletion of the specialcells (blanks) will most likely be deleting a great number of disjoint rows or row groups and that can be a significant slowing point. I suspect that is causing at least the majority of the time difference between our codes as my code deletes just one single block of rows.
• Another tiny time-saving could be achieved by altering how you fill/use the arrDelete array. Instead of marking the rows to keep in that array, if you mark the rows to delete then when you do the row deletions it will already have deleted any values in the extra column so there is no need to then delete (or clear) that extra column. If you look at my code you will see that I have done it that way (& for that reason).

* I didn't do a close analysis but I think the main reason the actual results differed were

• The CurrentRegion issue mentioned above
• My code (& the OP's) does a case-sensitive test for the text values whereas yours does not
• Your column R name comparison of "SARAH" v the post 1 name of "SARA" for that column.

 

[Alex Blakenburg]

@Peter_SSs - That was great feedback thank you for taking the time to test it and provide feedback. I had thought about doing a sort and my gut feel was that it would be faster but using specialcells seems to be the most commonly used approach so I thought I might be wrong. Sometimes the sort can take a while especially if there is a large volume with lots of formulas. Your testing showing that using a sort first is faster is especially helpful.
Thanks again.

 

[kapsikum]

But does it delete the correct rows?
If cell N10000 contains "John" the first run through the first loop for me deletes row 9993 not row 10000.

BTW, does your data actually go to row 10,000 or have you just used a big number to be sure?
If not 10,000 about how many rows does your data go to?

i havent checked what happens if the word "John" is at cell N10000 because i used a big number to be sure as i know it will not exceed that

 

[kapsikum]

Give this a try with a copy of your workbook and check accuracy & time.
Not sure what is in your worksheet but this took 0.125 seconds for my 10,000 rows of sample data.

Sub Dashboard_v3()
  Dim a As Variant, b As Variant
  Dim i As Long, nc As Long

  a = Range("L8:AS10000").Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    Select Case True
      Case a(i, 3) = "John": b(i, 1) = 1
      Case a(i, 1) = "TOM": b(i, 1) = 1
      Case a(i, 1) = "": b(i, 1) = 1
      Case a(i, 4) = "": b(i, 1) = 1
      Case a(i, 6) = "": b(i, 1) = 1
      Case a(i, 7) = "": b(i, 1) = 1
      Case a(i, 7) = "SARA": b(i, 1) = 1
      Case a(i, 7) = "BEN": b(i, 1) = 1
      Case a(i, 7) = "MEREDITH": b(i, 1) = 1
      Case a(i, 7) = "APRIL": b(i, 1) = 1
      Case a(i, 7) = "JASON": b(i, 1) = 1
      Case a(i, 7) = "SANA": b(i, 1) = 1
      Case a(i, 25) = "": b(i, 1) = 1
      Case a(i, 25) = "JUNE": b(i, 1) = 1
      Case a(i, 25) = "OCTOBER": b(i, 1) = 1
      Case a(i, 25) = "JANUARY": b(i, 1) = 1
      Case a(i, 34) = "": b(i, 1) = 1
    End Select
  Next i
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  With Range("A8:A10000").Resize(, nc)
    .Columns(nc).Value = b
    .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
    On Error Resume Next
    .Columns(nc).SpecialCells(xlConstants, xlNumbers).EntireRow.Delete
    On Error GoTo 0
  End With
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

I gave this code a try and it also works....i didnt time it exactly but it was quite fast, around the 2 second mark....

 

[Peter_SSs]

i havent checked what happens if the word "John" is at cell N10000 because i used a big number to be sure as i know it will not exceed that

It doesn't matter which row "John" is in. If it is in N40 the code from post #2 will delete row 33 not row 40.

I gave this code a try and it also works....i didnt time it exactly but it was quite fast, around the 2 second mark....

A fair bit faster than 40 minutes or even 5 minutes though. Assuming that it does the correct deletions of course.

 

[johnnyL]

I decided to take a swing at this, knowing full well that it is very difficult, for me at least, to come up with better code than what @Peter_SSs provides.

I, sadly, report that I could not beat the completion time of @Peter_SSs's code, but, I did come up with some alternative code that produces roughly the same time for completion.

Sub Dashboard_JohnnyLV2()
'
    Dim StartTime               As Single
    StartTime = Timer                                                                   ' Start the stop watch
'
    Application.ScreenUpdating = False
'
    Dim ColumnNumber            As Long, RowNumber      As Long
    Dim LastColumnNumberInSheet As Long
    Dim LastRow                 As Long
    Dim CodeCompletionTime      As Single
    Dim DesiredInputColumns     As String
    Dim LastColumnInSheet       As String
    Dim InputArray              As Variant, OuputArray  As Variant
'
'---------------------------------------------------------------------------
'
    LastRow = 10007                                                                     ' Set the LastRow of the sheet
    LastColumnInSheet = Split(Cells(1, (Cells.Find("*", , xlFormulas, , xlByColumns, _
            xlPrevious).Column) + 1).Address, "$")(1)                                   ' Get the Last Column Letter used in the sheet & add 1 to it
    LastColumnNumberInSheet = Cells.Find("*", , xlFormulas, , xlByColumns, _
            xlPrevious).Column + 1                                                      ' Get the Last Column Number used in the sheet & add 1 to it
'
    DesiredInputColumns = "12,14,15,17,18,36,45"                                        ' Set the column #s from the source sheet to be loaded into array
'
    InputArray = Application.Index(Cells, Evaluate("ROW(8:" & LastRow & ")"), _
            Split(DesiredInputColumns, ","))                                            ' Load the designated column #s into InputArray
'
    ReDim OuputArray(1 To UBound(InputArray, 1), 1 To 1)                                ' Set # of rows & columns for the OuputArray
'
'   InputArray now contains 7 columns of data (Columns L,N,O,Q,R,AJ,AS) from the source sheet.
'
'---------------------------------------------------------------------------
'
    For ColumnNumber = LBound(InputArray, 2) To UBound(InputArray, 2)                   ' Loop through the columns of the InputArray
        For RowNumber = LBound(InputArray, 1) To UBound(InputArray, 1)                  '   Loop through the rows of the InputArray
            Select Case ColumnNumber                                                    '       Determine which column # is being looked at
                Case 1                                                                  '           If column # = 1 then ...
                    If Trim(InputArray(RowNumber, ColumnNumber)) = "" Or _
                            Trim(InputArray(RowNumber, ColumnNumber)) = "TOM" Then      '               If blank or 'TOM' found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
                Case 2                                                                  '           If column # = 2 then ...
                    If Trim(InputArray(RowNumber, ColumnNumber)) = "John" Then          '               If 'John' found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
                Case 3, 4, 7                                                            '           If column # = 3, 4, or 7 then ...
                    If Trim(InputArray(RowNumber, ColumnNumber)) = "" Then              '               If blank found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
                Case 5                                                                  '           If column # = 5 then ...
                    If InStr("APRILBENJASONMEREDITHSANASARA", _
                            Trim(InputArray(RowNumber, 5))) > 0 Then                    '               If any of the string names are found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
'
                    If Trim(InputArray(RowNumber, 5)) = "" Then                         '               If blank found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
                Case 6                                                                  '           If column # = 6 then ...
                    If InStr("JANUARYJUNEOCTOBER", _
                            Trim(InputArray(RowNumber, 6))) > 0 Then                    '               If any of the string names are found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
'
                    If Trim(InputArray(RowNumber, 6)) = "" Then                         '               If blank found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
            End Select
        Next                                                                            '   Loop back
    Next                                                                                ' Loop back
'
'---------------------------------------------------------------------------
'
    Range(LastColumnInSheet & "8").Resize(UBound(OuputArray, 1)) = OuputArray           ' Display the OuputArray to sheet
'
    With Range("A8:A" & LastRow).Resize(, LastColumnNumberInSheet)
        .Sort Key1:=.Columns(LastColumnNumberInSheet), Order1:=xlAscending, Header:=xlNo    ' Sort the sheet based on the OuputArray column
    End With
'
    On Error Resume Next                                                                ' Ignore error encountered if next line yields no rows to delete
    Columns(LastColumnNumberInSheet).SpecialCells(xlCellTypeConstants, _
            xlErrors).EntireRow.Delete                                                  ' Delete all rows from sheet marked for deletion
'
    Application.ScreenUpdating = True                                                   ' Turn ScreenUpdating back on
'
    CodeCompletionTime = Timer - StartTime                                              ' Stop the stop watch
    CodeCompletionTime = Format(CodeCompletionTime, ".#####")                           ' Prevent scientific notation results
    Debug.Print "Time to complete = " & CodeCompletionTime & " seconds."                ' Display the time elapsed to the user (Ctrl-G)
End Sub

 

[kapsikum]

I decided to take a swing at this, knowing full well that it is very difficult, for me at least, to come up with better code than what @Peter_SSs provides.

I, sadly, report that I could not beat the completion time of @Peter_SSs's code, but, I did come up with some alternative code that produces roughly the same time for completion.

Sub Dashboard_JohnnyLV2()
'
    Dim StartTime               As Single
    StartTime = Timer                                                                   ' Start the stop watch
'
    Application.ScreenUpdating = False
'
    Dim ColumnNumber            As Long, RowNumber      As Long
    Dim LastColumnNumberInSheet As Long
    Dim LastRow                 As Long
    Dim CodeCompletionTime      As Single
    Dim DesiredInputColumns     As String
    Dim LastColumnInSheet       As String
    Dim InputArray              As Variant, OuputArray  As Variant
'
'---------------------------------------------------------------------------
'
    LastRow = 10007                                                                     ' Set the LastRow of the sheet
    LastColumnInSheet = Split(Cells(1, (Cells.Find("*", , xlFormulas, , xlByColumns, _
            xlPrevious).Column) + 1).Address, "$")(1)                                   ' Get the Last Column Letter used in the sheet & add 1 to it
    LastColumnNumberInSheet = Cells.Find("*", , xlFormulas, , xlByColumns, _
            xlPrevious).Column + 1                                                      ' Get the Last Column Number used in the sheet & add 1 to it
'
    DesiredInputColumns = "12,14,15,17,18,36,45"                                        ' Set the column #s from the source sheet to be loaded into array
'
    InputArray = Application.Index(Cells, Evaluate("ROW(8:" & LastRow & ")"), _
            Split(DesiredInputColumns, ","))                                            ' Load the designated column #s into InputArray
'
    ReDim OuputArray(1 To UBound(InputArray, 1), 1 To 1)                                ' Set # of rows & columns for the OuputArray
'
'   InputArray now contains 7 columns of data (Columns L,N,O,Q,R,AJ,AS) from the source sheet.
'
'---------------------------------------------------------------------------
'
    For ColumnNumber = LBound(InputArray, 2) To UBound(InputArray, 2)                   ' Loop through the columns of the InputArray
        For RowNumber = LBound(InputArray, 1) To UBound(InputArray, 1)                  '   Loop through the rows of the InputArray
            Select Case ColumnNumber                                                    '       Determine which column # is being looked at
                Case 1                                                                  '           If column # = 1 then ...
                    If Trim(InputArray(RowNumber, ColumnNumber)) = "" Or _
                            Trim(InputArray(RowNumber, ColumnNumber)) = "TOM" Then      '               If blank or 'TOM' found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
                Case 2                                                                  '           If column # = 2 then ...
                    If Trim(InputArray(RowNumber, ColumnNumber)) = "John" Then          '               If 'John' found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
                Case 3, 4, 7                                                            '           If column # = 3, 4, or 7 then ...
                    If Trim(InputArray(RowNumber, ColumnNumber)) = "" Then              '               If blank found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
                Case 5                                                                  '           If column # = 5 then ...
                    If InStr("APRILBENJASONMEREDITHSANASARA", _
                            Trim(InputArray(RowNumber, 5))) > 0 Then                    '               If any of the string names are found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
'
                    If Trim(InputArray(RowNumber, 5)) = "" Then                         '               If blank found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
                Case 6                                                                  '           If column # = 6 then ...
                    If InStr("JANUARYJUNEOCTOBER", _
                            Trim(InputArray(RowNumber, 6))) > 0 Then                    '               If any of the string names are found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
'
                    If Trim(InputArray(RowNumber, 6)) = "" Then                         '               If blank found then ...
                        OuputArray(RowNumber, 1) = "#N/A"                               '                   Save '#N/A' into OuputArray
                    End If
            End Select
        Next                                                                            '   Loop back
    Next                                                                                ' Loop back
'
'---------------------------------------------------------------------------
'
    Range(LastColumnInSheet & "8").Resize(UBound(OuputArray, 1)) = OuputArray           ' Display the OuputArray to sheet
'
    With Range("A8:A" & LastRow).Resize(, LastColumnNumberInSheet)
        .Sort Key1:=.Columns(LastColumnNumberInSheet), Order1:=xlAscending, Header:=xlNo    ' Sort the sheet based on the OuputArray column
    End With
'
    On Error Resume Next                                                                ' Ignore error encountered if next line yields no rows to delete
    Columns(LastColumnNumberInSheet).SpecialCells(xlCellTypeConstants, _
            xlErrors).EntireRow.Delete                                                  ' Delete all rows from sheet marked for deletion
'
    Application.ScreenUpdating = True                                                   ' Turn ScreenUpdating back on
'
    CodeCompletionTime = Timer - StartTime                                              ' Stop the stop watch
    CodeCompletionTime = Format(CodeCompletionTime, ".#####")                           ' Prevent scientific notation results
    Debug.Print "Time to complete = " & CodeCompletionTime & " seconds."                ' Display the time elapsed to the user (Ctrl-G)
End Sub

I like the idea of showing the time elapsed...thank you very much for that!