Macro needed for extracting to Tab

[KiloHotel]

Hi all,

I am wondering if there is a way of extracting a range of cells into seperate tabs from the one long sheet.

Let me give you my issue,

I have one sheet with alot of tables and data, Someone glued it all together and i need each table into separate tabs,

At present it is currently like this:

[TABLE="width: 200"]
<tbody>[TR]
[TD]SOB[/TD]
[TD]BBEE[/TD]
[/TR]
[TR]
[TD]TEST 1[/TD]
[TD]TEST1[/TD]
[/TR]
[TR]
[TD]TEST 2[/TD]
[TD]TEST3[/TD]
[/TR]
[TR]
[TD]TEST 3[/TD]
[TD]TEST3[/TD]
[/TR]
[TR]
[TD]SOB[/TD]
[TD]BBEE[/TD]
[/TR]
[TR]
[TD]TEST11[/TD]
[TD]TEST11[/TD]
[/TR]
[TR]
[TD]TEST12[/TD]
[TD]TEST13[/TD]
[/TR]
</tbody>[/TABLE]


So Anywhere Cell A & B say SOB & BBEE it is a new table all the way down until it says it again. The tables vary in length and they are not all the same. but there is 250+ tables all glued like this (idiotic) but i am screaming for help at this stage if anyone can please


Thanks!

 

[Fluff]

In a blank cell somewhere enter this
=COUNTIF(D:D,"SOB")

What answer does it give?

 

[KiloHotel]

In a blank cell somewhere enter this
=COUNTIF(D:D,"SOB")

What answer does it give?

106

 

[Fluff]

Ok, try this

Sub chk()
   Dim Ws As Worksheet
   Dim Ar As Areas
   Dim Rng As Range
   
   Set Ws = ActiveSheet
   With Ws.Range("D1", Ws.Range("D" & Rows.Count).End(xlUp))
      .Replace "SOB", "=XXSOB", xlWhole, , False, , False, False
      Set Ar = .SpecialCells(xlConstants).Areas
      .Replace "=XX", "", xlPart, , False, , False, False
      MsgBox Ar.Count
   End With
End Sub

What does the msgbox say?

 

[KiloHotel]

Ok, try this

Sub chk()
   Dim Ws As Worksheet
   Dim Ar As Areas
   Dim Rng As Range
   
   Set Ws = ActiveSheet
   With Ws.Range("D1", Ws.Range("D" & Rows.Count).End(xlUp))
      .Replace "SOB", "=XXSOB", xlWhole, , False, , False, False
      Set Ar = .SpecialCells(xlConstants).Areas
      .Replace "=XX", "", xlPart, , False, , False, False
      MsgBox Ar.Count
   End With
End Sub

What does the msgbox say?

It says 891.

 

[Fluff]

Do you have any blank cells in col D?

 

[KiloHotel]

Do you have any blank cells in col D?

Yes there is some blanks

 

[Fluff]

Ok try this

Sub Splitdata()

   Dim Ws As Worksheet
   Dim Ar As Areas
   Dim i As Long
   
   Set Ws = ActiveSheet
   Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = "SOB"
   With Ws.Range("A1", Ws.Range("A" & Rows.Count).End(xlUp))
      .Replace "SOB", "=XXSOB", xlWhole, , False, , False, False
      Set Ar = .SpecialCells(xlFormulas, xlErrors).Areas
      .Replace "=XX", "", xlPart, , False, , False, False
      For i = 1 To Ar.Count - 1
         Worksheets.Add , Sheets(Sheets.Count)
         Ar(i).Resize(Ar(i + 1).Row - 1).EntireRow.Copy ActiveSheet.Range("A1")
      Next i
   End With
End Sub

 

[KiloHotel]

Ok try this

Sub Splitdata()

   Dim Ws As Worksheet
   Dim Ar As Areas
   Dim i As Long
   
   Set Ws = ActiveSheet
   Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = "SOB"
   With Ws.Range("A1", Ws.Range("A" & Rows.Count).End(xlUp))
      .Replace "SOB", "=XXSOB", xlWhole, , False, , False, False
      Set Ar = .SpecialCells(xlFormulas, xlErrors).Areas
      .Replace "=XX", "", xlPart, , False, , False, False
      For i = 1 To Ar.Count - 1
         Worksheets.Add , Sheets(Sheets.Count)
         Ar(i).Resize(Ar(i + 1).Row - 1).EntireRow.Copy ActiveSheet.Range("A1")
      Next i
   End With
End Sub

Nothing happened with that one, No error message and no other tab opened... I even went through it with F8 to see if it done anything and nothing..

 

[Fluff]

Bolux forgot to change it back to col D after testing.

   Ws.Range("[COLOR=#ff0000]D[/COLOR]" & Rows.Count).End(xlUp).Offset(1).Value = "SOB"
   With Ws.Range("[COLOR=#ff0000]D1[/COLOR]", Ws.Range("[COLOR=#ff0000]D[/COLOR]" & Rows.Count).End(xlUp))

 

[KiloHotel]

Bolux forgot to change it back to col D after testing.

   Ws.Range("[COLOR=#ff0000]D[/COLOR]" & Rows.Count).End(xlUp).Offset(1).Value = "SOB"
   With Ws.Range("[COLOR=#ff0000]D1[/COLOR]", Ws.Range("[COLOR=#ff0000]D[/COLOR]" & Rows.Count).End(xlUp))

OMFG it worked! I cannot thank you enough for your hard work sir! I think you saved me 7 - 8 days of extraction! I can now tackle this tomorrow... 250+ workbooks. YOU THE MAN !!!!