VBA - Excel insert row above for each cell containing certain text - excel

Question

How do you go through the specific worksheet and in a specific column for every row that contains word "firewall" - then insert an empty row above? The Row with "firewall" may be followed by rows that contain other values. The last line in the column is always "Grand Total". I supposed can be used as condition to stop the loop.
I found on Stack Overflow this example which is almost exactly what I need, but it does it only once, and I need through the entire column for all matches. The worksheet should be specified.
Sub NewRowInsert()
Dim SearchText As String
Dim GCell As Range
SearchText = "Original"
Set GCell = Worksheets("Sheet2").Cells.Find(SearchText).Offset(1)
GCell.EntireRow.Insert
End Sub
My data example:
firewall abc
policy x
policy y
firewall xyz
policy z
policy xxx
Grand Total

Answer 1

Insert Rows (Find feat. Union)
Option Explicit
Sub NewRowInsert()
Const sText As String = "FirEWaLL"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim rg As Range: Set rg = ws.Range("A2:A" & LastRow)
Dim sCell As Range: Set sCell = rg.Find(sText, , xlFormulas, xlPart)
Application.ScreenUpdating = False
Dim trg As Range
Dim sCount As Long
If Not sCell Is Nothing Then
Dim FirstAddress As String: FirstAddress = sCell.Address
Do
If trg Is Nothing Then
Set trg = sCell
Else
Set trg = Union(trg, sCell.Offset(, sCount Mod 2))
End If
sCount = sCount + 1
Set sCell = rg.FindNext(sCell)
Loop Until sCell.Address = FirstAddress
trg.EntireRow.Insert
End If
Application.ScreenUpdating = True
Select Case sCount
Case 0
MsgBox "'" & sText & "' not found.", vbExclamation, "Fail?"
Case 1
MsgBox "Found 1 occurrence of '" & sText & "'.", _
vbInformation, "Success"
Case Else
MsgBox "Found " & sCount & " occurrences of '" & sText & "'.", _
vbInformation, "Success"
End Select
End Sub