Delete Criteria Rows Efficiently Using AutoFilter
Sub DeleteCriteriaRows()
Const PROC_TITLE As String = "Delete Criteria Rows"
Const SRC_NAME As String = "Graphs"
Const SRC_FIRST_CELL As String = "Q31"
Const DST_NAME As String = "Projects"
Const DST_FIRST_CELL As String = "A3"
Const DST_CRIT_COL As Long = 1
Const DST_FLAG_STRING As String = "!|!"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim dict As Object
Set dict = DictSingleColumnRange(wb, SRC_NAME, SRC_FIRST_CELL)
If dict Is Nothing Then Exit Sub
Dim fRows As Long: fRows = DeleteMultiCriteriaRows( _
wb, DST_NAME, DST_FIRST_CELL, DST_CRIT_COL, dict, DST_FLAG_STRING)
If fRows > 0 Then
MsgBox fRows & " row" & IIf(fRows = 1, "", "s") & " deleted.", _
vbInformation, PROC_TITLE
End If
End Sub
Function DictSingleColumnRange( _
ByVal wb As Workbook, _
ByVal WorksheetName As String, _
ByVal FirstCell As String) _
As Object
Const PROC_TITLE As String = "Single Column Range To Dictionary"
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = wb.Sheets(WorksheetName)
If ws.FilterMode Then ws.ShowAllData
Dim rg As Range, rCount As Long
With ws.Range(FirstCell)
Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If Not lCell Is Nothing Then
rCount = lCell.Row - .Row + 1
Set rg = .Resize(rCount)
End If
End With
If rg Is Nothing Then
MsgBox "No data found!", vbCritical, PROC_TITLE
Exit Function
End If
Dim Data()
If rCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
Else
Data = rg.Value
End If
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long, rString As String
For r = 1 To rCount
rString = CStr(Data(r, 1))
If Len(rString) > 0 Then dict(rString) = Empty
Next r
If dict.Count = 0 Then
MsgBox "Only blank cells found!", vbCritical, PROC_TITLE
Exit Function
End If
Set DictSingleColumnRange = dict
ProcExit:
Exit Function
ClearError:
MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
& Err.Description, vbCritical, PROC_TITLE
Resume ProcExit
End Function
Function DeleteMultiCriteriaRows( _
ByVal wb As Workbook, _
ByVal WorksheetName As String, _
ByVal FirstCell As String, _
ByVal CriteriaColumn As Long, _
ByVal CriteriaDictionary As Object, _
Optional ByVal FlagString As String = "!|!") _
As Long
Const PROC_TITLE As String = "Delete Multi-Criteria Rows"
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = wb.Sheets(WorksheetName)
If ws.FilterMode Then ws.ShowAllData
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim rg As Range
With ws.Range(FirstCell)
Set rg = Intersect(.EntireRow.Resize(ws.Rows.Count - .Row + 1), _
ws.UsedRange)
End With
If rg Is Nothing Then
MsgBox "No data found.", vbCritical, PROC_TITLE
Exit Function
End If
Dim rCount As Long: rCount = rg.Rows.Count - 1
Dim cCount As Long: cCount = rg.Columns.Count
If rCount = 0 Then
MsgBox "Only headers found.", vbCritical, PROC_TITLE
Exit Function
End If
' Flag criteria column.
Dim fRows As Long, WasFlagged As Boolean
With rg.Resize(rCount).Offset(1)
With rg.Columns(CriteriaColumn)
Dim Data(): Data = .Value
Dim r As Long
For r = 1 To rCount
If CriteriaDictionary.Exists(CStr(Data(r, 1))) Then
Data(r, 1) = FlagString
fRows = fRows + 1
WasFlagged = True
End If
Next r
If WasFlagged Then .Value = Data
End With
End With
If Not WasFlagged Then
MsgBox "No criteria found.", vbExclamation, PROC_TITLE
Exit Function
End If
' Expand the range by one column to hold an ascending integer sequence.
cCount = cCount + 1
Set rg = rg.Resize(, cCount)
' Delete rows and clean up.
Application.ScreenUpdating = False
With rg.Resize(rCount).Offset(1)
' Write an ascending integer sequence to the added column.
.Columns(cCount).Value = ws.Evaluate("ROW(1:" & rCount & ")")
' Sort by the criteria column to end up with a single filtered area.
.Sort .Columns(CriteriaColumn), xlAscending, , , , , , xlNo
' Delete filtered rows.
rg.AutoFilter CriteriaColumn, FlagString
Dim dfrg As Range: Set dfrg = .SpecialCells(xlCellTypeVisible)
ws.AutoFilterMode = False
dfrg.Delete xlShiftUp
' Sort by the added column to restore initial order.
.Sort .Columns(cCount), xlAscending, , , , , , xlNo
' Clear the added column.
.Columns(cCount).ClearContents
End With
DeleteMultiCriteriaRows = fRows
ProcExit:
If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
Exit Function
ClearError:
MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
& Err.Description, vbCritical, PROC_TITLE
Resume ProcExit
End Function
