My original should work. For some reason it is not macthing the word Topic.
The my code keeps on moving the variable FirstRow everytime it finds the
word Topic and only copies the section of your data from this variable to the
end of the range. I've used this code plentity of times and it works very
well. It looks like your code uses the Left function. Is there more than
the word TOPIC in the cell?

The line below isn't working properly with your data. Try making changes to
this one line of code to get it to work right. I added trim to remove any
spaces and Left to get only the first 5 characters.

from
If (UCase(.Range("I" & (RowCount + 1))) = "TOPIC") Or _
(RowCount = LastRow) Then
to
If UCase(left(trim(.Range("I" & (RowCount + 1))),5)) = "TOPIC" Or _
(RowCount = LastRow) Then

Your code doesn't even look for the word Topic so how can it work? I would
of tried to modied you code if I thought I could get it to work. Your code
is also putting a formula into the worksheet that is not required. My code
is very simple. It is less statements and easier to understand. Try getting
it to work. I have over 30 years of experience programming and have a
Bachlor in Electrical Enginering and a Master in Computer Science.


"CurlyDave" wrote:

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