Option Explicit
Sub try()
Dim lRowLast&, i&, rng, f, u, ad As String
lRowLast = Cells(Rows.Count, 1).End(xlUp).Row
' get union of rows match
'find 1st match
Set f = Range("A1:A" & lRowLast).Find("*COLLECTION*")
If Not f Is Nothing And f.Offset(-1, 0).Value <> "BALANCE" Then ' if match and upper cell value <> "BALANCE"
Set u = f
ad = f.Address
Do
Set f = Range("A1:A" & lRowLast).FindNext(f) ' find next match
If Not f Is Nothing And f.Offset(-1, 0).Value <> "BALANCE" Then Set u = Union(u, f)
Loop Until f.Address = ad
u.EntireRow.Insert
End If
' find match then add text
lRowLast = Cells(Rows.Count, 1).End(xlUp).Row
Set f = Range("A1:A" & lRowLast).Find("*COLLECTION*")
ad = f.Address
If Not f Is Nothing And f.Offset(-1, 0).Value = "" Then
With f.Offset(-1, 0)
.Value = "BALANCE"
.Font.Color = RGB(0, 0, 0)
End With
Do
Set f = Range("A1:A" & lRowLast).FindNext(f)
If Not f Is Nothing And f.Offset(-1, 0).Value = "" Then
With f.Offset(-1, 0)
.Value = "BALANCE"
.Font.Color = RGB(0, 0, 0)
End With
End If
Loop Until f.Address = ad
End If
End Sub