Faster code to delete cells through multiple worksheets in excel - vba

Question

i am a beginner in VB and having googled and looked through the answers here i have written the following loop to cycle through multiple excel worksheets and delete rows where the cells contain specific elements (N/A # N/A#).
The data in the xl sheet to be cleaned is financial data with DATE, OPEN. HIGH LOW CLOSE. the number of rows can be significant and the number of worksheets can be 2-300. It works but is very very slow and as I am learning - would appreciate any assistance on how i can make this code faster. Thank you.
Sub DataDeleteStage1()
ScreenUpdating = False
Dim lrow As Long
Dim ws As Worksheet
Dim icntr As Long
For Each ws In ThisWorkbook.Worksheets
lrow = ws.Cells(Rows.CountLarge, "a").End(xlUp).Row
For icntr = lrow To 1 Step -1
If ws.Name <> "HEADER" Then
If ws.Cells(icntr, "B") = "#N/A N/A" And ws.Cells(icntr, "C") = "#N/A N/A" And ws.Cells(icntr, "D") = "#N/A N/A" And ws.Cells(icntr, "E") = "#N/A N/A" Then
ws.Rows(icntr).EntireRow.Delete
End If
End If
Next icntr
Next ws
End Sub

Answer 1

Try merging all Ranges to be deleted to a MergeRng object, and then just delete it all at once.
Code
Sub DataDeleteStage1()
ScreenUpdating = False
Dim lrow As Long
Dim ws As Worksheet
Dim icntr As Long
Dim MergeRng As Range
For Each ws In ThisWorkbook.Worksheets
With ws
lrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For icntr = lrow To 1 Step -1
If .Name <> "HEADER" Then
If .Cells(icntr, "B") = "#N/A N/A" And .Cells(icntr, "C") = "#N/A N/A" And .Cells(icntr, "D") = "#N/A N/A" And .Cells(icntr, "E") = "#N/A N/A" Then
If Not MergeRng Is Nothing Then
Set MergeRng = Application.Union(MergeRng, .Rows(icntr))
Else
Set MergeRng = .Rows(icntr)
End If
End If
End If
Next icntr
' Delete all rows at once
If Not MergeRng Is Nothing Then MergeRng.Delete
End With
Set MergeRng = Nothing ' reset range when changing worksheets
Next ws
End Sub

Answer 2

You can make your code delete only once and not every time.
In order to make it like this, try the following:
Sub DataDeleteStage1()
Application.ScreenUpdating = False
Dim lrow As Long
Dim ws As Worksheet
Dim icntr As Long
Dim delRange As Range
For Each ws In ThisWorkbook.Worksheets
lrow = ws.Cells(Rows.CountLarge, "a").End(xlUp).Row
For icntr = lrow To 1 Step -1
If ws.Name <> "HEADER" Then
If ws.Cells(icntr, "B") = "#N/A N/A" And _
ws.Cells(icntr, "C") = "#N/A N/A" And _
ws.Cells(icntr, "D") = "#N/A N/A" And _
ws.Cells(icntr, "E") = "#N/A N/A" Then
If Not delRange Is Nothing Then
Set delRange = ws.Rows(icntr)
Else
Set delRange = Union(delRange, ws.Rows(icntr))
End If
End If
End If
Next icntr
If Not delRange Is Nothing Then delRange.Delete
Set delRange = Nothing
Next ws
End Sub
I have not tried it, but it should work.

Answer 3

How about this?
Sub DeleteRows()
Dim ws As Worksheet
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "HEADER" Then
On Error Resume Next
ws.Columns("B:E").Replace "#N/A N/A", "=NA()"
ws.Columns("B:E").SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete
End If
Next ws
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Answer 4

With AutoFilter and without looping altogether:
Sub DataDeleteStage1()
Dim ws As Worksheet
Dim lr As Integer
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
With ws
lr = .Range("A" & .Rows.Count).End(xlUp).Row
If ws.Name <> "HEADER" Then
.UsedRange.AutoFilter Field:=2, Criteria1:="#N/A"
.UsedRange.AutoFilter Field:=3, Criteria1:="#N/A"
.UsedRange.AutoFilter Field:=4, Criteria1:="#N/A"
.UsedRange.AutoFilter Field:=5, Criteria1:="#N/A"
.Range("A2:A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Delete shift:=xlUp
End If
End With
Next ws
Application.ScreenUpdating = True
End Sub
Tested this vs. the merged range approach on 300K rows - faster by minutes when doing multiple sheets.

Answer 5

I haven't tested but try this,
Sub DataDeleteStage1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim lrow As Long
Dim ws As Worksheet
Dim icntr As Long
For Each ws In ThisWorkbook.Worksheets
lrow = ws.Cells(Rows.CountLarge, "a").End(xlUp).Row
If ws.Name <> "HEADER" Then
On Error Resume Next
Range("F1:F" & lrow).Formula = "=IF(SUMPRODUCT(--ISERROR(A1:E1))=5,NA(),"""")"
Range("F1:F" & lrow).SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete shift:=xlUp
Range("F1:F" & lrow).Clear
End If
Next ws
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub