Find the ranges and then change values and such.

e.g.
[VBA]'xld, http://www.vbaexpress.com/forum/showthread.php?t=38802, see module, mDeleteRowsFromBottomUp

' Chip Pearson, http://www.cpearson.com/excel/FindAll.aspx

'Kenneth, http://www.vbaexpress.com/forum/showthread.php?t=38802
Sub Test_FoundRanges()
Dim findRange As Range, findString As String, foundRange As Range
Dim r As Range, i As Long

On Error GoTo EndNow:
'http://vbaexpress.com/kb/getarticle.php?kb_id=1035
SpeedOn

Set findRange = ActiveSheet.Range("A1:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row)
findString = "Allocation"
Set foundRange = FoundRanges(findRange, findString)
If foundRange Is Nothing Then GoTo EndNow

'If Not foundRange Is Nothing Then MsgBox foundRange.Address 'Note that range is in reverse order
'If Not foundRange Is Nothing Then foundRange.EntireRow.Delete
'For i = i to foundRange.Areas.Count
' foundRange.Areas(i).EntireRow.Delete
'Next i

EndNow:
SpeedOff
End Sub

Function FoundRanges(fRange As Range, fStr As String) As Range
Dim objFind As Range
Dim rFound As Range, FirstAddress As String

With fRange
Set objFind = .Find(what:=fStr, After:=fRange.Cells((fRange.Rows.Count), fRange.Columns.Count), _
LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=True)
If Not objFind Is Nothing Then
Set rFound = objFind
FirstAddress = objFind.Address
Do
Set objFind = .FindNext(objFind)
If Not objFind Is Nothing Then Set rFound = Union(objFind, rFound)
Loop While Not objFind Is Nothing And objFind.Address <> FirstAddress
End If
End With
Set FoundRanges = rFound
End Function[/VBA]