VBA Delete rows if cell contains specific text within a string

[gray_b]

Expanding on VBA Delete rows if cell contains specific text

1 - How can I make it search for say "Dog" within a string in a cell of say "My Dog plays games"

Changing - If (Cells(i, "B").Value) = "Dog"

to something like

If (Cells(i, "B").Value) = "*Dog*"

That does not work, but any ideas please.

Also
2 - To search for multiple words for say "Dog" "Cat" "Mouse" within a strings of say "My Dog plays games" and "My Cat is sleeping" and "Mouse has 4 legs"

Changing - If (Cells(i, "B").Value) = "Dog" or "Cat" or "Mouse"

That does not work, but any ideas please.

 

[Anthony47]

Replace the current If (Cells(I, "B").Value) = "Dog*" Then with

If InStr(1, Cells(I, "B").Value, "Dog", vbTextCompare) > 0 Then

For multiple searches, use OR:

If InStr(1, Cells(I, "B").Value, "Dog", vbTextCompare) > 0 Or _
 InStr(1, Cells(I, "B").Value, "Cat", vbTextCompare) > 0 Or _
 InStr(1, Cells(I, "B").Value, "Wolf", vbTextCompare) > 0 Then

Try...

 

[Peter_SSs]

To search for multiple words for say "Dog" "Cat" "Mouse" within a strings of say "My Dog plays games" and "My Cat is sleeping" and "Mouse has 4 legs"

Judging by your examples and your text, you want to look for words not text strings?
That is, you would not want to delete the row if the text was "Tom was dogmatic" or "The birds scattered"?
Please clarify.

Also, about how many rows of data do you expect to have to check?

 

[Alex Blakenburg]

I also assumed you wanted words. So here are a couple of options.
Note: It won't pick up words immediately preceded or followed by punctuation ie full stop or comma.

Sub Option1_Like()

    Dim sTxt As String
    Dim i As Long
    
    i = 7
    sTxt = " " & UCase(Cells(i, "B").Value) & " "
    ' search terms must be entered in uppercase
    ' or you need to wrap the right hand side in Ucase as well
    If sTxt Like "* DOG *" Or _
        sTxt Like "* CAT *" Or _
        sTxt Like "* MOUSE *" Then
        
        MsgBox "Found"
        
    End If

End Sub

Sub Option2_InStr()

    Dim sTxt As String
    Dim i As Long
    
    i = 7
    sTxt = " " & Cells(i, "B").Value & " "
    ' Not case sensitive
    If InStr(1, sTxt, " dog ", vbTextCompare) > 0 Or _
        InStr(1, sTxt, " cat ", vbTextCompare) > 0 Or _
        InStr(1, sTxt, " mouse ", vbTextCompare) > 0 Then
        
        MsgBox "Found"
    Else
        MsgBox "Not Found"
        
    End If

End Sub

 

[gray_b]

Judging by your examples and your text, you want to look for words not text strings?
That is, you would not want to delete the row if the text was "Tom was dogmatic" or "The birds scattered"?
Please clarify.

Also, about how many rows of data do you expect to have to check?

Yes you are right, complete words, not parts of words within the each cell text

 

[Peter_SSs]

complete words, not parts of words

Thanks for that clarification.

Unfortunately, no clarification to this one though.

Also, about how many rows of data do you expect to have to check?

Never-the-less, give this a try with a copy of your data. You should find it very fast, especially if your data is large.
I have assumed that the column to check is column B. Change in the code where indicated for another column.

Sub Del_Rws()
  Dim RX As Object
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.IgnoreCase = True    '<- Remove this line if you want the word search to be case-sensitive
  RX.Pattern = "\b(Dog|Cat|Mouse)\b"
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  a = Range("B2", Range("B" & Rows.Count).End(xlUp)).Value '<- Change column if required
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If RX.test(a(i, 1)) Then
      b(i, 1) = 1
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A2").Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub

My sample data BEFORE:

gray_b.xlsm
	A	B	C	D
1	Hdr1	Hdr2	Hdr3	Hdr4
2	a2	abc	data	data
3	a3	My Dog plays games	data	data
4	a4	Tom was dogmatic	data	data
5	a5	def	data	data
6	a6		data	data
7	a7	ghi	data	data
8	a8	The birds scattered	data	data
9	a9	My cat likes milk	data	data
10	a10		data	data
11	a11	Mouse has 4 legs	data	data
12	a12	Dog	data	data
Sheet3

AFTER:

gray_b.xlsm
	A	B	C	D
1	Hdr1	Hdr2	Hdr3	Hdr4
2	a2	abc	data	data
3	a4	Tom was dogmatic	data	data
4	a5	def	data	data
5	a6		data	data
6	a7	ghi	data	data
7	a8	The birds scattered	data	data
8	a10		data	data
9
Sheet3

 

[gray_b]

Also, about how many rows of data do you expect to have to check?

Sorry I forgot to answer this. Probably the max is 2000 rows.

 

[gray_b]

Set RX = CreateObject("VBScript.RegExp")

Error

Runtime error 70 - Permission denied

 

[Peter_SSs]

Sorry I forgot to answer this. Probably the max is 2000 rows.

Thanks.

Error

Runtime error 70 - Permission denied

The code runs fine for me. I wonder if something like this might be your issue?
Excel VBA > Run-time error ’70’: Permission Denied

 

[gray_b]

The code runs fine for me. I wonder if something like this might be your issue?
Excel VBA > Run-time error ’70’: Permission Denied

Blow me down, its was Malwarebytes protecting me. The debug/faulting in Excel did not highlight that as the problem.

I would never have located that.

Your main coding above worked first time. Many thanks