VBA - Find multiple strings in sheet and delete row

[d3kk3r]

Hi everyone,

I'm new to excel VBA and would like some help with a specific issue.

I have a worksheet with variable columns and rows.

I need to find multiple strings in each cell of the sheet and delete the entire row if any of the values are found

I was trying to adapt something like this:

Sub deleteRow()
    Dim MyValue As String
    Dim strValueToRemove As Variant
    
    strValueToRemove = Array("Value1", "Value2", "Value3", "Value4")

    For Each cell In ActiveSheet.UsedRange.Cells
    
        MyValue = CStr(cell.Value)
        For a = 1 To 6
            If InStr(1, MyValue, strValueToRemove(a), vbTextCompare) > 0 Then
                cell.EntireRow.Delete
                Exit For
            End If
        Next
        
    Next cell

End Sub

But don't know how.

Can anyone help?

Thanks!

 

[kevin9999]

Please try the following on a copy of your data. Adjust the sheet name and values searched for to suit.

Option Explicit
Sub d3kk3r()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<~~ change sheet as appropriate
    
    Dim lRow As Long, lCol As Long
    lRow = ws.Cells.Find("*", , xlFormulas, , 1, 2).Row
    lCol = ws.Cells.Find("*", , xlFormulas, , 2, 2).Column
    
    Dim rng As Range
    Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lRow, lCol))
    
    Dim a, b, vals
    a = rng.Value
    ReDim b(1 To UBound(a), 1 To 1)
    
    vals = Array("Value1", "Value2", "Value3", "Value4")    '<~~ change to the actual values searching for
    Dim i As Long, j As Long, k As Long
    For i = LBound(a, 1) To UBound(a, 1)
        For j = LBound(a, 2) To UBound(a, 2)
            For k = LBound(vals) To UBound(vals)
                If InStr(1, a(i, j), vals(k), 0) > 0 Then b(i, 1) = 1
            Next k
        Next j
    Next i
    
    lCol = lCol + 1
    ws.Cells(2, lCol).Resize(lRow - 1).Value = b
    i = WorksheetFunction.Sum(Columns(lCol))
    Range(Cells(2, 1), Cells(lRow, lCol)).Sort Key1:=Cells(2, lCol), order1:=1, Header:=2
    If i > 0 Then Cells(2, lCol).Resize(i).EntireRow.Delete
    
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
End Sub

 

[d3kk3r]

Worked like a charm!

thank you

 

[kevin9999]

Worked like a charm!

thank you

Glad it helped and thanks for the feedback