VBA script causes Excel to not respond after 15 loops - vba

Question

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

Answer 1

Every time I run the script after 5 seconds my cursor becomes the spinning circle and the excel program becomes unresponsive.
That's normal. VBA is running on the single available UI thread, the same one Excel runs on. While it's busy running your loop, it's not able to respond to other stimuli, and tells you that by putting "(not responding)" in the title bar, until it completes the work and is able to resume doing everything else it needs to do (i.e. listen for mouse & keyboard messages, etc.).
You could add a little DoEvents in the body of that loop to allow Excel to breathe and process pending messages between iterations, but then there's a catch: first, your code will take even longer to complete, and second, if the user is able to select/activate another sheet in the middle of that loop, then this unqualified Range call:
vData = Range(.Cells(1, 20), .Cells(635475, 20))
...will be the source of a run-time error 1004, since you can't do Sheet1.Range(Sheet2.Cells(1,20), Sheet2.Cells(635475,20)) and expect Excel to know what to do with that (assuming Sheet2 was active when the loop started, and the user activated Sheet1 in the middle of it).
This answer provides what appears to be the most efficient approach to conditionally deleting lines when a lot of rows are involved. If you can, add a helper column to calculate your criteria (e.g. make it return TRUE for rows to keep and FALSE for rows to delete), then use Worksheet.Replace and Worksheet.SpecialCells to perform the filtering and deletion:
.Columns("Z:Z").Replace What:=False, _
Replacement:="", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
.Columns("Z:Z").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Then you don't need a loop, and it might actually complete before you get to count to 5 seconds.
Other than that, long-running operations are just that: long-running operations. Own it:
Application.StatusBar = "Please wait..."
Application.Cursor = xlWait
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'..code..
Application.Cursor = xlDefault
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.StatusBar = False

Answer 2

This seems pretty quick. It puts results in U1 and down so you'd probably want to amend that. This extracts the values you want into a second array.
Sub removeWrongYear()
Dim i As Long, vData As Variant, v2(), j As Long
vData = Range(Cells(1, 20), Cells(635475, 20))
ReDim v2(1 To UBound(vData, 1), 1 To 1)
For i = UBound(vData) To 2 Step -1
If Val(Right(vData(i, 1), 2)) <= 17 Then
j = j + 1
v2(j, 1) = vData(i, 1)
End If
Next i
Range("U1").Resize(j, 1) = v2
End Sub

Answer 3

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
Before
After

Answer 4

This code process 635475 Rows x 20 Columns in 12.48 seconds on my fast computer and 33.32 seconds on my old computer (0.84 and 2.06 seconds for 38k x 20).
Option Explicit
Sub removeWrongYear2()
Const DATE_COLUMN = 20
Dim StartTime As Double: StartTime = Timer
Dim data() As Variant, results() As Variant
Dim c As Long, r As Long, r2 As Long
With ActiveSheet
data = .UsedRange.Value
ReDim results(1 To UBound(data), 1 To UBound(data, 2))
For r = 2 To UBound(data)
If Val(Right(data(r, DATE_COLUMN), 2)) <= 17 Then
r2 = r2 + 1
For c = 1 To UBound(data, 2)
results(r2, c) = data(r, c)
Next
End If
Next
If r2 > 0 Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
.UsedRange.Offset(1).Value = results
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End If
End With
Debug.Print Round(Timer - StartTime, 2)
End Sub
Sub Setup()
Dim data, r, c As Long
Const LASTROW = 635475
Cells.Clear
data = Range(Cells(1, 1), Cells(LASTROW, 20)).Value
For r = 1 To UBound(data)
For c = 1 To 19
data(r, c) = Int((LASTROW * Rnd) + 100)
Next
data(r, 20) = Int((10 * Rnd) + 10)
Next
Application.ScreenUpdating = False
Range(Cells(1, 1), Cells(LASTROW, 20)).Value = data
Application.ScreenUpdating = True
End Sub

Answer 5

Sort() & AutoFilter() are always a good pair:
Sub nn()
Dim sortRng As Range
With ActiveSheet.UsedRange ' reference all data in active sheet
With .Offset(, .Columns.Count).Resize(, 1) ' get a helper column right outside data
.Formula = "=ROW()" ' fill it with sequential numbers from top to down
.Value = .Value ' get rid of formulas
Set sortRng = .Cells ' store the helper range
End With
With .Resize(, .Columns.Count + 1) ' consider data and the helper range
.Sort key1:=.Cells(1, 20), order1:=xlAscending, Header:=xlNo ' sort it by data in column 20
.AutoFilter Field:=20, Criteria1:=">=01/01/2018" ' filter it for data greater than 2017
.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete ' delete filtered data
.Parent.AutoFilterMode = False ' remove filter
.Sort key1:=sortRng(1, 1), order1:=xlAscending, Header:=xlNo ' sort things back by means of helper column
.Columns(.Columns.Count).ClearContents ' clear helper column
End With
End With
End Sub
in my test a 768k row by 21 columns data took 11 seconds