Keyword Identification and Changes

hi
4c7b-Untitled-picture.png
I'm doing my job using the code below
But In fact, the words (keywords) I want to delete are in the column "c"

I mean the keyword is not just a word
I have a lot of words in the column that is added to them daily.
Is there a friend who corrects my code according to the image.

thanks

Sub Demo()
Dim dataRng As Range
Dim foundCell As Range
Dim ary() As String
On Error Resume Next
' remove empty cells
ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
' group cells by "t.me/canxl/" and add name for each group
Set dataRng = ActiveSheet.UsedRange 'Range("A1:A19")
With dataRng
    Set c = .Find("t.me/canxl/", LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            Set c = .FindNext(c)
            ReDim Preserve ary(i)
            ary(i) = c.Row
            i = i + 1
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
    First = LBound(ary)
    Last = UBound(ary)
    For i = First To Last - 1
        For j = i + 1 To Last
            If ary(i) - ary(j) > 0 Then
                Temp = ary(j)
                ary(j) = ary(i)
                ary(i) = Temp
            End If
        Next j
    Next i
Dim xName As Name
For Each xName In Application.ActiveWorkbook.Names
    xName.Delete
Next
For i = 0 To UBound(ary) - 1
ActiveWorkbook.Names.Add Name:="Group" & i + 1, RefersTo:=Range(Range("A" & ary(i)), Range("A" & ary(i + 1) - 1))
Next
ActiveWorkbook.Names.Add Name:="Group" & UBound(ary) + 1, RefersTo:=Range(Range("A" & ary(UBound(ary))), dataRng.End(xlDown))
' search which group contains keyword and delete the named range
With dataRng
    Set c = .Find("Keyword", LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            Set c = .FindNext(c)
            For Each xName In Application.ActiveWorkbook.Names
            If Not Intersect(c, Range(xName)) Is Nothing Then
            If Rng Is Nothing Then
            Set Rng = Range(xName)
            Else
            Set Rng = bigRange
            End If
            Set bigRange = Application.Union(Range(xName), Rng)
            xName.Delete
            End If
            Next
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
bigRange.Delete
If Error.Count > 0 Then
Error.Clear
End If
End Sub