This works for the first cell that has title "Shop Report", but it will not
continue to the next and to the end

Sub b10shop()


Dim MyRange As Range
Dim MyCell As Range
Dim EndRow As Integer

EndRow = Range("E65536").End(xlUp).Row
Set MyRange = Range("E1:E" & EndRow)
MyRange.Select
On Error Resume Next
For Each MyCell In MyRange
If MyCell.value = "Shop" Then
Cells.Find(What:="Shop Report", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("E4").Select
ActiveCell.FormulaR1C1 = "=R[3]C[-4]"
End If
Next MyCell
End Sub


--
Stacia