VBA Code runs for a very long time

kapsikum · Apr 12, 2022

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:

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

offthelip · Apr 12, 2022

I have changed all your loops to use a variant array for the testing which should make it much faster. this could be imporved even more but this was a simple edit
so try this:

VBA Code:

Sub Dashboard()
Application.ScreenUpdating = False
Dim rng As Variant, i As Integer

' range to evaluate
 rng = Range("N8:N10000")

'Loop backwards through the rows in the range to evaluate
For i = UBound(rng, 1) To 1 Step -1

'If cell i in the range contains "x", delete the entire row
If rng(i, 1) = "John" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete name Tom
 rng = Range("L8:L10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "TOM" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Blanks
 rng = Range("L8:L10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next


'Delete Blanks
 rng = Range("O8:O10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Blanks
 rng = Range("Q8:Q10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Blanks
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Sara
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "SARA" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Ben
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "BEN" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Meredith
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "MEREDITH" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete April
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "APRIL" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Jason
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "JASON" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Sana
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "SANA" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Blanks
 rng = Range("AJ8:AJ10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete June
 rng = Range("AJ8:AJ10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "JUNE" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete October
 rng = Range("AJ8:AJ10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "OCTOBER" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete January
 rng = Range("AJ8:AJ10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "JANUARY" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Blanks
 rng = Range("AS8:AS10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next
Application.ScreenUpdating = True
End Sub

kapsikum · Apr 12, 2022

offthelip said:

I have changed all your loops to use a variant array for the testing which should make it much faster. this could be imporved even more but this was a simple edit
so try this:

VBA Code:

Sub Dashboard()
Application.ScreenUpdating = False
Dim rng As Variant, i As Integer

' range to evaluate
 rng = Range("N8:N10000")

'Loop backwards through the rows in the range to evaluate
For i = UBound(rng, 1) To 1 Step -1

'If cell i in the range contains "x", delete the entire row
If rng(i, 1) = "John" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete name Tom
 rng = Range("L8:L10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "TOM" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Blanks
 rng = Range("L8:L10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next


'Delete Blanks
 rng = Range("O8:O10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Blanks
 rng = Range("Q8:Q10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Blanks
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Sara
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "SARA" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Ben
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "BEN" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Meredith
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "MEREDITH" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete April
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "APRIL" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Jason
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "JASON" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Sana
 rng = Range("R8:R10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "SANA" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Blanks
 rng = Range("AJ8:AJ10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete June
 rng = Range("AJ8:AJ10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "JUNE" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete October
 rng = Range("AJ8:AJ10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "OCTOBER" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete January
 rng = Range("AJ8:AJ10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "JANUARY" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next

'Delete Blanks
 rng = Range("AS8:AS10000")
For i = UBound(rng, 1) To 1 Step -1
If rng(i, 1) = "" Then Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
Next
Application.ScreenUpdating = True
End Sub

Thank you very much! It works!

offthelip · Apr 12, 2022

how long did it take??

Peter_SSs · Apr 12, 2022

kapsikum said:
Thank you very much! It works!

Really?
It produced different results to your code for me.

northwolves · Apr 12, 2022

Replace strings to blanks then use specialcells property of "Range " Object to location cells,as the following:

VBA Code:

Sub test()
'Delete Blanks
Set Rng = Range("R8:R10000")

'New codes
'------------------------------
Dim s, i&
s = Array("SARA", "BEN", "MEREDITH", "APRIL", "JASON", "SANA")
For i = 0 To 5
Rng.Replace s(i), "", xlWhole
Next
Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'-------------------------------------------------
'''
'''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
End Sub

Hope it helps.

kapsikum · Apr 12, 2022

offthelip said:
how long did it take??

4 minutes and 52 seconds to be exact which is a major improvement compared to before

Peter_SSs · Apr 12, 2022

kapsikum said:
4 minutes and 52 seconds to be exact which is a major improvement compared to before

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?

Peter_SSs · Apr 12, 2022

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.

VBA Code:

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

Alex Blakenburg · Apr 12, 2022

This is a bit long winded but I would be interested to know how it performs on your full data set.
I have assumed your data starts in column A though.

VBA Code:

Sub Dashboard_Test()

    Dim rng As Range
    Dim arrRng As Variant
    Dim arrDelete() As String
    Dim iDelCnt As Long
    Dim i As Long
    Dim j As Variant, sMatch As Variant
    Dim bDel As Boolean
    Dim fltrRng As Range
 
    Dim aColN As Variant, aColL As Variant, aColO As Variant, aColQ As Variant
    Dim aColR As Variant, aColAJ As Variant, aColAS As Variant
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Set rng = Range("A8").CurrentRegion
    arrRng = rng
    ReDim arrDelete(1 To UBound(arrRng), 1 To 1)
 
    aColL = Array("Tom", "")
    aColN = Array("John")
    aColO = Array("")
    aColQ = Array("")
    aColR = Array("", "SARAH", "BEN", "MEREDITH", "APRIL", "JASON", "SANA")
    aColAJ = Array("", "JUNE", "OCTOBER", "JANUARY")
    aColAS = Array("")
 
    iDelCnt = 0
 
    For i = 1 To UBound(arrRng)
        For Each j In Array("12", "14", "15", "17", "18", "36", "45")
            Select Case j
                Case 12         ' ColL
                    For Each sMatch In aColL
                        If StrComp(arrRng(i, j), sMatch, vbTextCompare) = 0 Then
                            iDelCnt = iDelCnt + 1
                            bDel = True
                            Exit For
                        End If
                    Next sMatch
            
                Case 14         ' ColN
                    For Each sMatch In aColN
                        If StrComp(arrRng(i, j), sMatch, vbTextCompare) = 0 Then
                            iDelCnt = iDelCnt + 1
                            bDel = True
                            Exit For
                        End If
                    Next sMatch
            
                Case 15         ' ColO
                    For Each sMatch In aColO
                        If StrComp(arrRng(i, j), sMatch, vbTextCompare) = 0 Then
                            iDelCnt = iDelCnt + 1
                            bDel = True
                            Exit For
                        End If
                    Next sMatch
                
                Case 17         ' ColQ
                    For Each sMatch In aColQ
                        If StrComp(arrRng(i, j), sMatch, vbTextCompare) = 0 Then
                            iDelCnt = iDelCnt + 1
                            bDel = True
                            Exit For
                        End If
                    Next sMatch
                
                Case 18         ' ColR
                    For Each sMatch In aColR
                        If StrComp(arrRng(i, j), sMatch, vbTextCompare) = 0 Then
                            iDelCnt = iDelCnt + 1
                            bDel = True
                            Exit For
                        End If
                    Next sMatch
                
                Case 36         ' ColAJ
                    For Each sMatch In aColAJ
                        If StrComp(arrRng(i, j), sMatch, vbTextCompare) = 0 Then
                            iDelCnt = iDelCnt + 1
                            bDel = True
                            Exit For
                        End If
                    Next sMatch
                
                Case 45         ' ColAS
                    For Each sMatch In aColAS
                        If StrComp(arrRng(i, j), sMatch, vbTextCompare) = 0 Then
                            iDelCnt = iDelCnt + 1
                            bDel = True
                            Exit For
                        End If
                    Next sMatch
            End Select
        
            If bDel Then
                Exit For
            End If
        Next j
    
        If bDel = False Then
            arrDelete(i, 1) = "KEEP"
        End If
        bDel = False
    Next i
 
    Set fltrRng = rng.Columns(rng.Columns.Count).Offset(, 1)
    fltrRng.Value = arrDelete
    fltrRng.Cells(1, 1).Value = "Filter Column"
 
    fltrRng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    fltrRng.EntireColumn.Delete

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

VBA Code runs for a very long time

kapsikum

New Member

Excel Facts

offthelip

Well-known Member

kapsikum

New Member

offthelip

Well-known Member

Peter_SSs

MrExcel MVP, Moderator

northwolves

Well-known Member

kapsikum

New Member

Peter_SSs

MrExcel MVP, Moderator

Peter_SSs

MrExcel MVP, Moderator

Alex Blakenburg

MrExcel MVP

Similar threads

Forum statistics

Share this page

VBA Code runs for a very long time

New Member

Excel Facts

Well-known Member

New Member

Well-known Member

MrExcel MVP, Moderator

Well-known Member

New Member

MrExcel MVP, Moderator

MrExcel MVP, Moderator

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock