Thanks,
But it would just copy the entire sheet to a new sheet,
Here is what I came up with, I am not advanced enough to know how to
store results into memory, if anybody can show me how to do this
without using a helper sheet, that would be terrific, Thanks

Sub FindSummary()

Dim MySheet As Worksheet
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim s As Variant
Dim X As Integer
s = "Summary"
Set ws = Worksheets("Sheet2")
Set ws1 = Worksheets("Sheet1")
ws.Columns("A:A").ClearContents

X = 0

For Each Cell In ws1.UsedRange
p = InStr(1, Cell.Formula, s, 1)
If p = 1 Then
ws.Range("A1").Offset(X, 0).Value = Cell.Address
ws.Range("A1").Offset(X, 1) = "=LEFT(RC[-1],
3)&RIGHT(RC[-1],LEN(RC[-1])-3)-1"
X = X + 1
End If
Next
SendToNewSheet
End Sub
Sub SendToNewSheet()
Dim r As Range
Dim c As Range
Dim ws3 As Worksheet
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
Set ws3 = Worksheets("Sheet2")
Set r = ws3.Range("A1", ws3.Range("A65356").End(xlUp))
For Each c In r.Cells
If c.Offset(1, 0) < "" Then

ws.Range(c.Value, c.Offset(1, 1).Value).EntireRow.Cut
Sheets.Add
ActiveSheet.Paste
ws.Select
End If

Next c
End Sub