DELETE ROWS , IF CONTAINS A SPECIFIC WORD / WORDS

[SAQIBN]

Hi

I have following Code for:

Search from Column C, and delete the If Contains a "Specific word".

but now i want to add more criteria .
like:
if it contains "Roger" or "George" or "Lilly"
then delete those Rows...

Code is as follows:

Sub test()
With ActiveSheet
    .AutoFilterMode = False
    With Range("d1", Range("d" & Rows.Count).End(xlUp))
        .AutoFilter 1, "*Roger*"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
End With
End Sub

 

[SAQIBN]

Excuse,

Search from Column D,

 

[JEC]

How about this

Sub jec()
 Dim a() As Variant, ar As Variant, it As Variant, XX As String, i As Long, x As Long
 ar = Range("d2", Range("d" & Rows.Count).End(xlUp))
 XX = InputBox("Choose names(comma seperated!)", "Filter")         'like:  roger,george,lilly
 
 For Each it In Split(XX, ",")
   For i = 1 To UBound(ar)
     If InStr(1, ar(i, 1), it, vbTextCompare) Then
        ReDim Preserve a(x)
        a(x) = ar(i, 1)
        x = x + 1
     End If
   Next
 Next
  
 With Range("d1", Range("d" & Rows.Count).End(xlUp))
   .AutoFilter 1, a, 7
   .Offset(1).EntireRow.Delete
   .AutoFilter
 End With
End Sub

 

[kevin9999]

A slightly alternative approach to JEC's (excellent) response, could be:

Option Explicit
Sub ConvertToZap()
    Dim ws As Worksheet, LR As Long, i As Long, Arr
    Set ws = Sheet1   '<~~ change to suit
    LR = ws.Cells(Rows.Count, 4).End(xlUp).Row
    Arr = ws.Range("D1:D" & LR)
   
    For i = 1 To LR
        If Arr(i, 1) Like "*Roger*" Or _
            Arr(i, 1) Like "*George*" Or _
            Arr(i, 1) Like "*Lilly*" Then
            Arr(i, 1) = "Zap"
        End If
    Next
   
    ws.Range("D1:D" & LR).Value = Arr
   
    With Range("D1:D" & LR)
       .AutoFilter 1, "Zap"
       .Offset(1).EntireRow.Delete
       .AutoFilter
    End With
End Sub

 

[SAQIBN]

How about this

Sub jec()
 Dim a() As Variant, ar As Variant, it As Variant, XX As String, i As Long, x As Long
 ar = Range("d2", Range("d" & Rows.Count).End(xlUp))
 XX = InputBox("Choose names(comma seperated!)", "Filter")         'like:  roger,george,lilly
 
 For Each it In Split(XX, ",")
   For i = 1 To UBound(ar)
     If InStr(1, ar(i, 1), it, vbTextCompare) Then
        ReDim Preserve a(x)
        a(x) = ar(i, 1)
        x = x + 1
     End If
   Next
 Next
 
 With Range("d1", Range("d" & Rows.Count).End(xlUp))
   .AutoFilter 1, a, 7
   .Offset(1).EntireRow.Delete
   .AutoFilter
 End With
End Sub

it's Amazing ..... ...

Stay Blessed !!!

 

[JEC]

Nice! You’re welcome!?

 

[SAQIBN]

Nice! You’re welcome!?

One More Thing Please!

Also I have some Blank Cells to delete ,
how to add criteria for "Blank" in Input Box....

 

[JEC]

A small change at the last part, it always deletes empty cells first.

Sub jec()
 Dim a() As Variant, ar As Variant, it As Variant, XX As String, i As Long, x As Long
 ar = Range("d2", Range("d" & Rows.Count).End(xlUp))
 XX = InputBox("Choose names(comma seperated!)", "Filter")         'like:  roger,george,lilly
 
 For Each it In Split(XX, ",")
   For i = 1 To UBound(ar)
     If InStr(1, ar(i, 1), it, vbTextCompare) Then
        ReDim Preserve a(x)
        a(x) = ar(i, 1)
        x = x + 1
     End If
   Next
 Next
 
 On Error Resume Next
 With Range("d1", Range("d" & Rows.Count).End(xlUp))
   .SpecialCells(xlCellTypeBlanks).Delete
   .AutoFilter 1, a, 7
   .Offset(1).EntireRow.Delete
   .AutoFilter
 End With
End Sub

 

[SAQIBN]

A small change at the last part, it always deletes empty cells first.

Sub jec()
 Dim a() As Variant, ar As Variant, it As Variant, XX As String, i As Long, x As Long
 ar = Range("d2", Range("d" & Rows.Count).End(xlUp))
 XX = InputBox("Choose names(comma seperated!)", "Filter")         'like:  roger,george,lilly
 
 For Each it In Split(XX, ",")
   For i = 1 To UBound(ar)
     If InStr(1, ar(i, 1), it, vbTextCompare) Then
        ReDim Preserve a(x)
        a(x) = ar(i, 1)
        x = x + 1
     End If
   Next
 Next
 
 On Error Resume Next
 With Range("d1", Range("d" & Rows.Count).End(xlUp))
   .SpecialCells(xlCellTypeBlanks).Delete
   .AutoFilter 1, a, 7
   .Offset(1).EntireRow.Delete
   .AutoFilter
 End With
End Sub

A small change at the last part, it always deletes empty cells first.

Sub jec()
 Dim a() As Variant, ar As Variant, it As Variant, XX As String, i As Long, x As Long
 ar = Range("d2", Range("d" & Rows.Count).End(xlUp))
 XX = InputBox("Choose names(comma seperated!)", "Filter")         'like:  roger,george,lilly
 
 For Each it In Split(XX, ",")
   For i = 1 To UBound(ar)
     If InStr(1, ar(i, 1), it, vbTextCompare) Then
        ReDim Preserve a(x)
        a(x) = ar(i, 1)
        x = x + 1
     End If
   Next
 Next
 
 On Error Resume Next
 With Range("d1", Range("d" & Rows.Count).End(xlUp))
   .SpecialCells(xlCellTypeBlanks).Delete
   .AutoFilter 1, a, 7
   .Offset(1).EntireRow.Delete
   .AutoFilter
 End With
End Sub

Dear JEC,
I've done all.
but last thing please,

Some values are duplicating or Triplicating in Column D,
want to keep 1 row, and delete others from duplication....

 

[JEC]

Try:

Sub jec()
 Dim a() As Variant, ar As Variant, it As Variant, XX As String, i As Long, x As Long
 Application.ScreenUpdating = False
 ar = Range("d2", Range("d" & Rows.Count).End(xlUp))
 XX = InputBox("Choose names(comma seperated!)", "Filter")         'like:  roger,george,lilly
 
 For Each it In Split(XX, ",")
   For i = 1 To UBound(ar)
     If InStr(1, ar(i, 1), it, vbTextCompare) Then
        ReDim Preserve a(x)
        a(x) = ar(i, 1)
        x = x + 1
     End If
   Next
 Next
 
 On Error Resume Next
 With Range("d1", Range("d" & Rows.Count).End(xlUp))
   .RemoveDuplicates 1, xlYes
   .SpecialCells(xlCellTypeBlanks).Delete
   .AutoFilter 1, a, 7
   .Offset(1).EntireRow.Delete
   .AutoFilter
 End With
End Sub