VBA to delete row based on criteria

[biggmann]

I am trying to wrote VBA code to delete rows if column "I" contains word Yes on sheet 1 I have named "Schedule". I have a button assigned to the macro I have and it does not show any errors but it will not delete anything. I was wondering if someone could look at this code and see why it isnt working.

Option Explicit
 

Sub Delete_Based_on_Criteria()

Dim X As Long
Dim Z As Long
Dim LastRow As Long
Dim FoundRowToDelete As Boolean
Dim OriginalCalculationMode As Long
Dim RowsToDelete As Range
Dim SearchItems() As String

Dim DataStartRow As Long
Dim SearchColumn As String
Dim SheetName As String



DataStartRow = 6
SearchColumn = "I"
SheetName = "Schedule"

SearchItems = Split("Yes", ",") 

On Error GoTo Whoops
OriginalCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

With Worksheets(SheetName)
LastRow = .Cells(.Rows.Count, SearchColumn).End(xlUp).Row
For X = LastRow To DataStartRow Step -1
FoundRowToDelete = False
For Z = 0 To UBound(SearchItems)
If InStr(.Cells(X, SearchColumn).Value, SearchItems(Z)) Then
FoundRowToDelete = True
Exit For
End If

Next

If FoundRowToDelete Then
If RowsToDelete Is Nothing Then
Set RowsToDelete = .Cells(X, SearchColumn)
Else
Set RowsToDelete = Union(RowsToDelete, .Cells(X, SearchColumn))
End If

If RowsToDelete.Areas.Count > 100 Then
RowsToDelete.EntireRow.Delete
Set RowsToDelete = Nothing
End If
End If

Next

End With
If Not RowsToDelete Is Nothing Then
RowsToDelete.EntireRow.Delete
End If

Whoops:
Application.Calculation = OriginalCalculationMode
Application.ScreenUpdating = True

 

End Sub

 

[b.downey]

The issue is with the "SearchItems" Variable. With the code you provided, the array will never have any data.

Change the following two lines:
Dim SearchItems() As String
SearchItems = Split("Yes", ",")

To the Following
Dim SearchItems as Variant
SearchItems = Array("Yes", "Test")

"Test" in the above line can have any seconday condition that you wish

 

[biggmann]

That worked, thanks for this I have been here for hours trying to find the error.

 

[Trebor76]

Hi biggmann,

Welcome to the forum!!

There seems to be a lot of code for a straight forward need.

See how this goes (initially on a copy of your data in case the results are not as expected):

Option Explicit
Sub Delete_Based_on_Criteria()

    'http://www.mrexcel.com/forum/showthread.php?t=588713

    Dim lngRowStart As Long, _
        lngRowEnd As Long
    Dim strCol As String, _
        strSheetName As String
    
    lngRowStart = 6
    strCol = "I"
    strSheetName = "Schedule"
    
    Application.ScreenUpdating = False

    With Sheets(strSheetName)
        lngRowEnd = .Cells(Rows.Count, strCol).End(xlUp).Row
        If lngRowEnd > lngRowStart Then
            With .Range(strCol & lngRowStart & ":" & strCol & lngRowEnd)
                .Replace "Yes", "#N/A", xlWhole
                On Error Resume Next ' Account for no cells from the array being found.
                    .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
                On Error GoTo 0
            End With
        End If
    End With
    
    Application.ScreenUpdating = True

End Sub

HTH

Robert