I have a word "Topic" in column I and then info,
then another "Topic" and so on
How does one select the range from the word "Topic", down to 1 row
short of the next word "Topic",
cut and paste that range into a new sheet,
Basically, all the "Topic"s need to be in there own sheets.

Thank You,

Sub Splittopics()

Set ThisSht = ActiveSheet
'set rowCount to first row with Item
RowCount = 1
FirstRow = RowCount
With ThisSht
LastRow = .Range("I" & Rows.Count).End(xlUp).Row
Do While RowCount <= LastRow
If (UCase(.Range("I" & (RowCount + 1))) = "TOPIC") Or _
(RowCount = LastRow) Then

Set newsht = Worksheets.Add(after:=Sheets(Sheets.Count))
.Rows(FirstRow & ":" & RowCount).Copy _
Destination:=newsht.Rows(1)
FirstRow = RowCount + 1
End If
RowCount = RowCount + 1
Loop
End With

End Sub

"CurlyDave" wrote:

I have a word "Topic" in column I and then info,
then another "Topic" and so on
How does one select the range from the word "Topic", down to 1 row
short of the next word "Topic",
cut and paste that range into a new sheet,
Basically, all the "Topic"s need to be in there own sheets.

Thank You,

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

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

Thanks Joel,
I changed the word to Summary,
The code works well, the word to find is a few hundred rows down, so
when I ran the code originally, the very first sheet added appeared to
be a duplicated of the first,
the last "Summary" section is not transferring all the rows to the new
sheet though, is this because it is only counting the rows in Column
I.

Probably it is due to the fact you are using Column I. Look at VBA Help
specialcells method. There is a property to find the last cell.

from
LastRow = .Range("I" & Rows.Count).End(xlUp).Row

to
LastRow = .specialcells(xlCellTypeLastCell).Row

"CurlyDave" wrote:


Thanks Joel,
I changed the word to Summary,
The code works well, the word to find is a few hundred rows down, so
when I ran the code originally, the very first sheet added appeared to
be a duplicated of the first,
the last "Summary" section is not transferring all the rows to the new
sheet though, is this because it is only counting the rows in Column
I.