From: jc on
I have a spreadsheet that has been subtotaled. The formula in the subtotal
cell is �=subtotal(3,j2:j61)� . Is there a way ,Using this information from
the subtotal formula, which is the number of rows with each client's info.
I would like to run a macro to copy the data from cells a2:q61 to a new
worksheet named with contents of cell �I�. This process needs to repeat
down thru aprox 6500 rows that have all been subtotaled down to 1500
separate lines .
From: joel on

Try this code. The code copies rows so it doesn't care the number of
columns. All it looks at is column A to get the Client Name and looks
for the word "Total" in column A to determine where each subtotal ends.


Sub SplitSubtotal()

'assume there is a header row which gets copied to each new sheet

Set Sourcesht = Sheets("Sheet1")

With Sourcesht
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
'ignore the Grand Total line if one exists
If InStr(UCase(.Range("A" & LastRow)), "GRAND") > 0 Then
LastRow = LastRow - 1
End If

StartRow = 2
RowCount = StartRow
For RowCount = StartRow To LastRow
If InStr(UCase(.Range("A" & RowCount)), "TOTAL") > 0 Then
client = .Range("A" & StartRow)
'create new sheet
Set newsht = Sheets.Add(after:=Sheets(Sheets.Count))
'changge sheet name to clients name
newsht.Name = client
'copy header row
.Rows(1).Copy Destination:=newsht.Rows(1)
'copy data
.Rows(StartRow & ":" & RowCount).Copy _
Destination:=newsht.Rows(2)
StartRow = RowCount + 1
End If

Next RowCount

End With

End Sub


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread: http://www.thecodecage.com/forumz/showthread.php?t=193510

http://www.thecodecage.com/forumz

From: jc on
Thank you Joel with a few modifications it went thru my whole list. If I
wished to copy each list to a seperate workbook in h:\clients\ rather than
seperate sheet. Thanks
Again
JC
From: joel on

The code below I didn't test but is very similar to the older macro.
You should be able to get it working like the last macro

Sub SplitSubtotal()

Folder = "h:\clients\"

'assume there is a header row which gets copied to each new sheet

Set Sourcesht = ThisWorkbook.Sheets("Sheet1")

With Sourcesht
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
'ignore the Grand Total line if one exists
If InStr(UCase(.Range("A" & LastRow)), "GRAND") > 0 Then
LastRow = LastRow - 1
End If

StartRow = 2
RowCount = StartRow
For RowCount = StartRow To LastRow
If InStr(UCase(.Range("A" & RowCount)), "TOTAL") > 0 Then
client = .Range("A" & StartRow)
'create new workbook
Set Newbook = Workbooks.Add(template:=xlWBATWorksheet)
Set newsht = Newbook.Sheets(1)
'change sheet name to clients name
newsht.Name = client
'copy header row
.Rows(1).Copy Destination:=newsht.Rows(1)
'copy data
.Rows(StartRow & ":" & RowCount).Copy _
Destination:=newsht.Rows(2)
StartRow = RowCount + 1
Newbook.SaveAs Filename:=Folder & client
Newbook.Close savechanges:=True
End If
Next RowCount

End With

End Sub


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread: http://www.thecodecage.com/forumz/showthread.php?t=193510

http://www.thecodecage.com/forumz

From: jc on
This is FANTASTIC!!!!!!!!!!!!!!!!!!!!!!
3 beers for Joel!!!
1 item I cant code is to expand the subtotaled data in the new workbooks. I
need to go to each sheet and click the + in the outline column. I have tried
all of the following


ReturnCurrentOutlineLevel = 2 'Most Detailed
'Sheet.Outline.ShowLevels RowLevels:=2, columnlevels:=2
'Application.Outline.ShowLevels RowLevels:=2, columnlevels:=2

I tried recording a macro to expand and nothing records.

Thanks again
JC