Macro to split up data from one column into multi sheets

[tonywatsonhelp]

Hi Everyone,

I'm looking for a macro to split the data up into different sheets,
The problem I have is there is no set number of rows between data so we have to find a word and use this word as the break for each new sheet, so I'm hoping someone can help me deal with this.

Heres what I have,

The document currently only has one tab, I will be running this on several docs but whilst I don't know the name of the sheet it will always be Sheets(1)
this sheet has data in column A and this is what I want to split up.

The criteria for splitting the rows is each section begins with a cell that starts with the words "Structure =" (

and some other word)​

so I want to split the data up using "Structure =" as the first row and the next "Structure =" as the last row -1

so we look down find

"Structure =" copy that section into its own tab and if possible rename the tab the word that comes after

"Structure ="

heres an example of what I have:

​

​

	A	B	C
1	these first few line will not contain any importatant data.
2
3	there can be empty rows in the sheet
4
5	data
6	data
7	Structure = Tony​ <strike></strike>	so first we start here
8		and create a new tab called "Tony"
9	blar	copy and paste all this data
10
11	bblarr
12	blar
13		down to here!
14	Structure = Bill​ <strike></strike>	then we create another tab called "Bill"
15	blar	copy and paste all this
16	blar
17
18	more blar
19	blar	down to here!
20	Structure = Dave​ <strike></strike>	then tab "Dave"
21	blar
22
23	blar	copy all in dave section
24	Structure = bob​ <strike></strike>	and finally BOB,
25	last one wont have a structure
26		not sur how you deal with this but to end of data.
27
28
29

<tbody>
</tbody>

So that's what I need, if you can help me please do.

Thank you very much

Tony​

 

[Fluff]

Try

Sub tonywatsonhelp()
   Dim Ar As Areas
   Dim i As Long, Lr As Long
   Dim Nme As String
   
   With Sheets(1)
      Lr = .Range("A" & Rows.Count).End(xlUp).Row
      With .Range("A1:A" & Lr)
         .Replace "Structure", "=XXXStructure", , , False, , False, False
         Set Ar = .SpecialCells(xlFormulas, xlErrors).Areas
         .Replace "=XXXStructure", "Structure", , , False, , False, False
      End With
      For i = 1 To Ar.Count
         Nme = Trim(Split(Ar(i).Item(1), "=")(1))
         Sheets.Add(, Sheets(Sheets.Count)).Name = Nme
         If i < Ar.Count Then
            Range(Ar(i), Ar(i + 1).Offset(-1)).Copy Sheets(Nme).Range("A1")
         Else
            Range(Ar(i), .Range("A" & Lr)).Copy Sheets(Nme).Range("A1")
         End If
      Next i
   End With
End Sub

 

[tonywatsonhelp]

Thank you fluff,
Tony

 

[Fluff]

You're welcome