Change the code from Exact Match to Phrase Match

[An Quala]

Hello Guys, this code is supposed to lookup the certain words in a different sheet and then delete the matching rows. For now it does not match "apple" in a "Pineapple", but I want to do so. If I put "apple", it also matches "Pineapple" in the row.

Your help will be highly appreciated.

Thank you!

Sub Delete_Rows(CP_KeyWordCol As String, ShName As String, ColToCheck As String)
  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
  With Sheets("Control Panel")
  If .Range(CP_KeyWordCol & Rows.Count).End(xlUp).Row >= 59 Then
    a = Application.Transpose(.Range(CP_KeyWordCol & "59", .Range(CP_KeyWordCol & Rows.Count).End(xlUp)).Value)
    If VarType(a) = vbVariant + vbArray Then
      RX.Pattern = "\b(" & Replace(Join(Filter(Split("#" & Join(a, "#|#"), "|"), "##", False), "|"), "#", "") & ")\b"
    Else
      RX.Pattern = "\b" & a & "\b"
    End If
    End If
  End With
 
If Len(RX.Pattern) > 0 Then
  With Sheets(ShName)
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = .Range(ColToCheck & "2", .Range(ColToCheck & Rows.Count).End(xlUp)).Value
    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 With
  End If
End Sub

Delete_Rows "O", "Sponsored Products Campaigns", "P"

Delete_Rows "Q", "Sponsored Brands Campaigns", "O"

Delete_Rows "S", "Sponsored Display Campaigns", "O"

 

[DanteAmor]

Change this:

RX.Pattern = "\b(" & Replace(Join(Filter(Split("#" & Join(a, "#|#"), "|"), "##", False), "|"), "#", "") & ")\b"

For this:

RX.Pattern = "(" & Replace(Join(Filter(Split("#" & Join(a, "#|#"), "|"), "##", False), "|"), "#", "") & ")"

 

[An Quala]

RX.Pattern = "(" & Replace(Join(Filter(Split("#" & Join(a, "#|#"), "|"), "##", False), "|"), "#", "") & ")"

Hi, it is actually still working the same way as before, for example if I put "Auto", it is not matching "Automotive" but only "Auto Motive".

 

[DanteAmor]

If in the "Control Panel" sheet you only put a value, then you must also change this line:
RX.Pattern = "\b" & a & "\b"

To this:
RX.Pattern = a

Remaining this way:

  With Sheets("Control Panel")
    If .Range(CP_KeyWordCol & Rows.Count).End(xlUp).Row >= 59 Then
      a = Application.Transpose(.Range(CP_KeyWordCol & "59", .Range(CP_KeyWordCol & Rows.Count).End(xlUp)).Value)
      If VarType(a) = vbVariant + vbArray Then
        RX.Pattern = "(" & Replace(Join(Filter(Split("#" & Join(a, "#|#"), "|"), "##", False), "|"), "#", "") & ")"
      Else
        RX.Pattern = a
      End If
    End If
  End With

 

[An Quala]

This works, thank you!