VBA seems to be deleting whole table while deleting filter

Question

currently have a vba code to loop through my workbook to remove rows containing "Dividend". The dataset is generally standardized and is in the confines of "A1:G101".

The code generally works fine except for instances where the row containing "Dividend" happens to be at row 101. The code proceeds to delete the whole table "A1:G101" instead along with the visible row.

Sub Delete_rows_Dividends()

 Dim ws As Worksheet

  For Each ws In Worksheets
 
   If ws.Name <> "Summary" And ws.Name <> "Dashboard" And ws.Name <> "Signals" Then
    
    On Error Resume Next
    ws.Range("A1:G101").AutoFilter Field:=2, Criteria1:="*Dividend*"
   
    Application.DisplayAlerts = False
    ws.Range("A2:G101").SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True
    
    ws.AutoFilter.ShowAllData
  End If
  
  Next ws
 
End Sub

Answer 1

Delete Criteria Rows (AutoFilter)

A Quick Fix

Sub Delete_rows_Dividends()

    Dim ws As Worksheet
    Dim trg As Range ' Table Range
    Dim drg As Range ' Data Range i.e. Table Range without headers

    For Each ws In Worksheets
        Select Case LCase(ws.Name) ' 'LCase' (or 'UCase') to ignore case ('A=a')
        Case "summary", "dashboard", "signals" ' the comma means 'Or'
        Case Else
            ' Remove previous filters.
            If ws.AutoFilterMode Then
                ws.AutoFilterMode = False
            End If
            ' First create the range references...
            Set trg = ws.Range("A1:G101")
            Set drg = ws.Range("A2:G101")
            ' ... only then apply the filter.
            trg.AutoFilter Field:=2, Criteria1:="*Dividend*"
            ' Prevent run-time error if no cells.
            On Error Resume Next
                ' Instead of 'Application.DisplayAlerts', use 'EntireRow'.
                drg.SpecialCells(xlCellTypeVisible).EntireRow.Delete
                ' Note that if you want to preserve possible data to the right
                ' of the table, you will have to create a backward loop
                ' through the areas of the 'special cells range' i.e. probably
                ' use another way.
            On Error GoTo 0
            ' Remove filter.
            ws.AutoFilterMode = False
        End Select
    Next ws
 
End Sub

An Improvement

• Adjust the values in the constants section.

Option Explicit

Sub DeleteCriteriaEntireRows()
    
    Const ExceptionsList As String = "Summary,Dashboard,Signals"
    Const ColsAddress As String = "B" ' or "A:G"
    Const fField As Long = 1 ' or 2, if "A:G"
    Const fCriteria As String = "*Dividend*"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim Exceptions() As String: Exceptions = Split(ExceptionsList, ",")

    Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim crg As Range ' Columns Range
    Dim lCell As Range ' Last (Bottom-Most) Non-empty Cell (in Columns Range)
    Dim trg As Range ' Table Range
    Dim drg As Range ' Data Range
    Dim lRow As Long ' Last Non-Empty Row
    
    For Each ws In wb.Worksheets
        If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
            If ws.AutoFilterMode Then
                ws.AutoFilterMode = False
            End If
            Set crg = ws.Columns(ColsAddress)
            Set lCell = crg.Find("*", , xlFormulas, , xlByRows, xlPrevious)
            If Not lCell Is Nothing Then
                lRow = lCell.Row
                If lRow > 1 Then
                    Set trg = crg.Resize(lRow)
                    Set drg = trg.Resize(lRow - 1).Offset(1)
                    trg.AutoFilter fField, fCriteria
                    On Error Resume Next
                        drg.SpecialCells(xlCellTypeVisible).EntireRow.Delete
                    On Error GoTo 0
                    ws.AutoFilterMode = False
                End If
            End If
        End If
    Next ws
 
    Application.ScreenUpdating = True

End Sub