VBA script causes Excel to not respond after 15 loops

  • A+

I am running a script to find and delete rows that contain data from after 2018. I am searching through around 650000 rows. Every time I run the script after 5 seconds my cursor becomes the spinning circle and the excel program becomes unresponsive. Here is the code I am using.

Option Explicit Option Base 1 'row and column index will match array index  Sub removeWrongYear()  Dim i As Long, yearA As Long, rowsCnt As Long Dim rowsToDelete As Range Dim vData As Variant  With ActiveSheet      '1st to 635475 row, 20th column     vData = Range(.Cells(1, 20), .Cells(635475, 20))      For i = UBound(vData) To 2 Step -1        If Val(Right(vData(i,1),2)) > 17 Then         Debug.Print Val(Right(vData(i,1),2))             rowsCnt = rowsCnt + 1              If rowsCnt > 1 Then                 Set rowsToDelete = Union(rowsToDelete, .Rows(i))             ElseIf rowsCnt = 1 Then                 Set rowsToDelete = .Rows(i)             End If          End If     Next i  End With  If rowsCnt > 0 Then     Application.ScreenUpdating = False     rowsToDelete.EntireRow.Delete     Application.ScreenUpdating = True End If  End Sub 

This uses an AutoFilter - the more rows to delete, the faster it gets

Rows: 1,048,575 (Deleted: 524,286), Cols: 21   (70 Mb xlsb file)  Time: 6.90 sec, 7.49 sec, 7.21 sec   (3 tests) 

Test data shown in images bellow

How it works

  • It generates a temporary helper column with formula "=RIGHT(T1, 2)" (first empty column)
  • Applies a filter for the years to keep ("<18") in the temp column
  • Copies all visible rows to a new sheet (not including the temp column)
  • Removes the initial sheet
  • Renames the new sheet to the initial sheet name

Option Explicit  Public Sub RemoveYearsAfter18()     Dim ws As Worksheet, wsName As String, lr As Long, lc As Long     Dim ur As Range, filterCol As Range, newWs As Worksheet      Set ws = Sheet1     'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")     wsName = ws.Name      lr = ws.Cells(ws.Rows.Count, "T").End(xlUp).Row         'Last Row in col T (or 635475)     lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'Last Col in row 1      Set ur = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc))     Set filterCol = ws.Range(ws.Cells(1, lc + 1), ws.Cells(lr, lc + 1)) 'Exclude Headers      OptimizeApp True     Set newWs = ThisWorkbook.Worksheets.Add(After:=ws)  'Add new sheet     With filterCol         .Formula = "=RIGHT(T1, 2)"         .Cells(1) = "FilterCol"                     'Column header         .Value2 = .Value2                           'Convert formulas to values for filter     End With     filterCol.AutoFilter Field:=1, Criteria1:="<18" 'Reverse filter      ur.Copy                                         'Copy visible data     With newWs.Cells         .PasteSpecial xlPasteColumnWidths         .PasteSpecial xlPasteAll                    'Paste data on new sheet         .Cells(1).Select     End With      ws.Delete                                       'Delete old sheet     newWs.Name = wsName     OptimizeApp False End Sub 

Private Sub OptimizeApp(ByVal speedUp As Boolean)     Application.Calculation = IIf(speedUp, xlCalculationManual, xlCalculationAutomatic)     Application.ScreenUpdating = Not speedUp     Application.DisplayAlerts = Not speedUp     Application.EnableEvents = Not speedUp End Sub 


VBA script causes Excel to not respond after 15 loops


VBA script causes Excel to not respond after 15 loops


:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen: