Excel VBA - Delete entire row if cell contains string1 or string2 or string3, etc

Viewed 753

I would like to remove a row if that row contains a specific string, but I need to do this many times for many strings.

To be more specific, my speadsheet is ~3000 rows and ~30 columns, but this changes every single day. The first column, and the only one I care about, is the name of a node on a network, and if that node starts with or contains a certain word (bananas, Apples, oranges, PINEAPPLES) I need the whole row deleted and everything to shift up

This is what I have so far with help from @chrisneilsen...

This does exactly what I need it to, but is there any code in there that I don't need, or could it be cleaned up? I've mashed up answers and suggestions from a few people and I'm wondering if I've created a monster...

Sub takeOutTheTrash()

    Dim rng As Range
    Dim ItemToDelete As Variant
    Dim ItemsToDelete As Variant
    ItemsToDelete = Array("Apple", "banana", "skittles", "grapes", "ORANGES")

    Set rng = ActiveSheet.UsedRange
    For Each ItemToDelete In ItemsToDelete
        deleteGarbage rng, ItemToDelete
    Next
    
End Sub

Sub deleteGarbage(rng As Range, Value As Variant)

    Dim pos As Long
    Dim rw As Long
    Dim col As Long

    For rw = rng.Rows.Count To 1 Step -1
        For col = 1 To rng.Columns.Count
            If InStr(LCase(rng.Cells(rw, col).Value2), LCase(Value)) > 0 Then
                rng.Rows(rw).EntireRow.Delete
                Exit For
            End If
        Next col
    Next rw
    
End Sub
3 Answers

Abstract the Delete Rows routine as a seperate Sub, and pass it your values

Something like

Sub testIt()
    Dim rng As Range

    Set rng = ActiveSheet.UsedRange
    deleteGarbage rng, "Bananas"
    deleteGarbage rng, "SomethingElse"
End Sub

' To delete many items, create a variable that contains the items and iterate that.  
'  Eg a Range, an Array, or a Collection/Dictionary
Sub testItMany()
    Dim rng As Range
    Dim ItemsToDelete As Some Collection Object or Array
    Dim ItemToDelete As Variant

    Set rng = ActiveSheet.UsedRange
    For Each ItemToDelete In ItemsToDelete 
        deleteGarbage rng, ItemToDelete
    Next
End Sub



Sub deleteGarbage(rng as Range, Value as Variant)
    Dim pos As Long
    Dim rw As Long
    Dim col As long

    For rw = rng.Rows.Count To 1 Step -1
        For col = 1 to rng.Columns.Count
            If InStr(LCase(rng.Cells(rw, col).Value2), LCase(Value)) > 0 Then
                rng.Rows(rw).EntireRow.Delete
                Exit For
            End If
        Next col
    Next rw 
End Sub

If this is too slow, there are optimisations you can make to speed it up (eg using Variant Arrays)

Delete Garbage

Option Explicit

Sub deleteGarbage()
    
    Dim Garbage As Variant
    Garbage = Array("bananas", "Apples", "oranges", "MAGIC MYSTERY LEGUMES", _
                    "Carrots")
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    Dim rng As Range: defineRange rng, ws
    If rng Is Nothing Then Exit Sub
    
    Dim Data As Variant: writeRangeToArray Data, rng
    
    Dim RowOffset As Long: RowOffset = rng.Row - 1 ' (1 = LBound(Data))
    
    Dim RowNumbers As Variant
    collectRowNumbers RowNumbers, Data, Garbage, RowOffset
    If UBound(RowNumbers) = -1 Then GoTo NoGarbage
    
    deleteRows ws, RowNumbers
    
    MsgBox "Deleted '" & UBound(RowNumbers) & "' row(s).", vbInformation, _
           "Success"
     
    Exit Sub
     
NoGarbage:
    MsgBox "No garbage found", vbExclamation, "No Garbage"
    Exit Sub
     
End Sub

Sub defineRange(ByRef aRange As Range, aSheet As Worksheet)
    ' This can be written better.
    Set aRange = aSheet.UsedRange
End Sub

Sub writeRangeToArray(ByRef Data As Variant, aRange As Range)
    If aRange.Cells.CountLarge > 1 Then
        Data = aRange.Value
    Else
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = aRange.Value
    End If
End Sub

Sub collectRowNumbers(ByRef RowNumbers As Variant, _
                      Data As Variant, _
                      Garbage As Variant, _
                      RowOffset As Long)
    
    Dim i As Long, j As Long, k As Long, Curr As String, Found As Boolean
    ReDim RowNumbers(1 To UBound(Data))
    
    For i = 1 To UBound(Data)
        For j = 1 To UBound(Data, 2)
            If VarType(Data(i, j)) = vbString Then
                Curr = Data(i, j)
                findStringInArray Found, Curr, Garbage
                If Found Then
                    k = k + 1
                    RowNumbers(k) = i + RowOffset
                    Exit For
                End If
            End If
        Next j
    Next i
    If k = 0 Then RowNumbers = Array(): Exit Sub
    ReDim Preserve RowNumbers(1 To k)
                
End Sub

Sub findStringInArray(ByRef foundString As Boolean, _
                      aString As String, _
                      Data1D As Variant)
    foundString = False
    Dim j As Long
    For j = LBound(Data1D) To UBound(Data1D)
        If InStr(1, Data1D(j), aString, vbTextCompare) > 0 Then
            foundString = True: Exit Sub
        End If
    Next j
End Sub

Sub deleteRows(aSheet As Worksheet, _
               RowNumbers As Variant)
    
    Dim uRng As Range: Set uRng = aSheet.Rows(RowNumbers(1))
    
    If UBound(RowNumbers) > 1 Then
        Dim i As Long
        For i = 2 To UBound(RowNumbers)
            Set uRng = Union(uRng, aSheet.Rows(RowNumbers(i)))
        Next i
    End If
    
    uRng.EntireRow.Delete ' for testing: uRng.EntireRow.Hidden = True

End Sub

Instead of looping, as already mentioned, you will be better off using built-in tools like filters:

Sub FilterAndDelete()

    Dim rng As Range
    Dim pos As Integer
    
    Set sht = Sheets("Sheet1")
    Set rng = ActiveSheet.UsedRange
    
    With sht
        rng.AutoFilter Field:=1, Criteria1:=Array("bananas", "oranges", "carrots"), _
                Operator:=xlFilterValues
        LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rng = .Range("A2:A" & LstRw).SpecialCells(xlCellTypeVisible)
        rng.EntireRow.Delete
        .AutoFilterMode = False
    End With

End Sub
Related