Excel VBA Repeatedly Delete Range with Specific String on Top Left - excel

Question

I would like to delete a certain range (3 rows & 19 columns) in excel that contains specific string (lns) on the top left of the range, repeatedly. They appear in different rows and columns, but the range size is always the same.
I have written a following code but nothing happens:
For Each vCell In ActiveSheet.UsedRange
If InStr(vCell.Value, "*lns*") Then
Range(Cells(vCell.Row, vCell.Column), Cells(vCell.Row + 2, vCell.Column + 18)).Delete shift:=xlShiftUp
End If
Next

Answer 1

It might be faster to locate the cells with Find
Option Explicit
Sub MyMacro()
Const ROW_SIZE = 3
Const COL_SIZE = 19
Const SEARCH = "lns"
Dim rng As Range, cel As Range
Dim n As Integer, s As Long
Set rng = ActiveSheet.UsedRange
Set cel = rng.Find(SEARCH, LookIn:=xlValues, lookat:=xlPart, _
searchdirection:=xlPrevious)
Do While Not cel Is Nothing
cel.Resize(ROW_SIZE, COL_SIZE).Delete shift:=xlShiftUp
n = n + 1
Set cel = rng.FindPrevious
If n > 1000 Then MsgBox "Code Error in Do Loop", vbCritical: Exit Sub
Loop
MsgBox n & " blocks deleted", vbInformation
End Sub

Answer 2

Delete Range 'Blocks'
Option Explicit
Sub DeleteBlocks()
Const rCount As Long = 3
Const cCount As Long = 19
Const Criteria As String = "lns"
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ActiveSheet.UsedRange
Dim fCell As Range
Set fCell = rg.Find(Criteria, rg.Cells(rg.Rows.Count, rg.Columns.Count), _
xlFormulas, xlPart, xlByRows)
Dim drg As Range ' Delete Range
Dim brg As Range ' Block Range
Dim fCount As Long ' Found Count
Dim FirstAddress As String
If Not fCell Is Nothing Then
FirstAddress = fCell.Address
Do
Set brg = Nothing
On Error Resume Next ' if in last 2 rows or 18 last columns
Set brg = Intersect(rg, fCell.Resize(rCount, cCount))
On Error GoTo 0
If Not brg Is Nothing Then
fCount = fCount + 1
Set drg = GetCombinedRange(drg, brg)
Set fCell = rg.FindNext(fCell)
End If
Loop Until fCell.Address = FirstAddress
If Not drg Is Nothing Then
drg.Delete Shift:=xlShiftUp
End If
If fCount = 1 Then
MsgBox "1 block deleted.", vbInformation, "DeleteBlocks"
Else
MsgBox fCount & " blocks deleted", vbInformation, "DeleteBlocks"
End If
Else
MsgBox "No blocks found.", vbExclamation, "DeleteBlocks"
End If
End Sub
Function GetCombinedRange( _
ByVal BuiltRange As Range, _
ByVal AddRange As Range) _
As Range
If BuiltRange Is Nothing Then
Set GetCombinedRange = AddRange
Else
Set GetCombinedRange = Union(BuiltRange, AddRange)
End If
End Function