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:

​

​

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]these first few line will not contain any importatant data.[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]there can be empty rows in the sheet[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]data[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]data[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]

Structure = Tony​

<strike></strike>
[/TD]
[TD]so first we start here[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]
[/TD]
[TD]and create a new tab called "Tony"[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]blar[/TD]
[TD]copy and paste all this data[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]bblarr[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]12[/TD]
[TD]blar[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]13[/TD]
[TD]
[/TD]
[TD]down to here![/TD]
[TD][/TD]
[/TR]
[TR]
[TD]14[/TD]
[TD]

Structure = Bill​

<strike></strike>
[/TD]
[TD]then we create another tab called "Bill"[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]15[/TD]
[TD]blar[/TD]
[TD]copy and paste all this[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]16[/TD]
[TD]blar[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]17[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]18[/TD]
[TD]more blar[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]19[/TD]
[TD]blar[/TD]
[TD]down to here![/TD]
[TD][/TD]
[/TR]
[TR]
[TD]20[/TD]
[TD]

Structure = Dave​

<strike></strike>
[/TD]
[TD]then tab "Dave"[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]21[/TD]
[TD]blar[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]22[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]23[/TD]
[TD]blar[/TD]
[TD]copy all in dave section [/TD]
[TD][/TD]
[/TR]
[TR]
[TD]24[/TD]
[TD]

Structure = bob​

<strike></strike>
[/TD]
[TD]and finally BOB,[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]25[/TD]
[TD]last one wont have a structure[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]26[/TD]
[TD][/TD]
[TD]not sur how you deal with this but to end of data.[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]27[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]28[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]29[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

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