split rows into multiple worksheets by header

[karissao]

I have a large excel worksheet with many groups in it. Each group begins with an identical header row. Currently, I just split up each group with page breaks.

I need to make a macro which splits each group into a separate worksheet tab each time it finds the header. Here is the header:

HSE STREET APT ZIP2 STATUS NAME PHONE MTHLY CUR BILL B1 B2 DIG HSD CDV Contact Refusal In-house Present COMMENTS

Please help!

 

[jbeaucaire]

Are there blank rows between the sections? If so, you could employ the .AREAS function in a macro to copy each area to a sheet of its own.

 

[karissao]

no- that won't work. The actual type of info in each packet varies- see below. But the header is always the same.

Header
data row
data row
data row
data row
header
image (several rows)
data row
blank row
header
data row

 

[karissao]

It would actually be just as good if it split into worksheets between manual page breaks, as there is a page break after every group.

 

[jbeaucaire]

Give this a try. It assumes the "COMMENTS" string is unique to each section.

The macro also assumes the first match is in row 1...

Option Explicit

Sub SplitGroups()
'JBeaucaire   2/5/2010
'Splits groups of data to separate sheets
Dim rFind As Range, rTop As Range, rFirst As Range
Dim dSht As Worksheet, Cnt As Long
Application.ScreenUpdating = False

Set dSht = Sheets("Sheet1")     'data sheet
Set rFirst = dSht.Range("A1")
Set rTop = dSht.Range("A1")
Set rFind = dSht.Cells.Find("COMMENTS", After:=dSht.[A2], LookIn:=xlValues, LookAt:=xlPart)

Do
    Cnt = Cnt + 1
    If rFind.Address <> rFirst.Address Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Group" & Cnt
        dSht.Range(rTop, rFind.Offset(-1, 0)).EntireRow.Copy Range("A1")
        Set rTop = rFind
        Set rFind = dSht.Cells.Find("HSE", After:=rFind, LookIn:=xlValues, LookAt:=xlPart)
    Else
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Group" & Cnt
        dSht.Range(rTop, dSht.Range("A" & Rows.Count).End(xlUp)).EntireRow.Copy Range("A1")
        Exit Do
    End If
Loop

Application.ScreenUpdating = True
End Sub

 

[karissao]

wow- not sure what happened, but by the time I aborted it, there were over 1600 sheets! It would awesome if you would email me at karissame.martin@gmail.com so I can send you the file I am trying to break up. Is that allowed?

 

[jbeaucaire]

You can trade email addresses using the forum's Private messaging system, so you don't have to post your email address in an open thread. Just click on the names to the left...

Meanwhile, I sent you an email...


The macro is using the word "COMMENTS" to spot each header and copying all the data in between rows with the word "COMMENTS" on them. That should work if "COMMENTS" is a unique text string to your headers.