Macro to copy subtotaled data

[jc]

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 .

 

[joel]

Try this code. The code copies rows so it doesn't care the number o
columns. All it looks at is column A to get the Client Name and look
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

 

[jc]

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

 

[joel]

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

 

[jc]

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

 

[joel]

The workbook created didn't havve macros enabled

Try this
from
Set Newbook = Workbooks.Add(template:=xlWBATWorksheet)
to
Set Newbook = Workbooks.Add(template:=xlWBATExcel4IntlMacroSheet)


Or

from
Newbook.SaveAs Filename:=Folder & client
to
Newbook.SaveAs Filename:=Folder & client, FileFormat:=xlExcel12

 

[jc]

I am not running the macros from the new workbooks I have a workbook called
MyMacros I store most macros in. Will changing this to macro enabled
workbook allow the subtotals to be expanded from a macro ran from a
different workbook. All the code you helped with works great , just the new
workbooks have coppied the data from the original workbook and left it
compressed subtotal. Hence the new workbook has just 1 visible row until the
subtotal "+" in the far left column is expanded.

 

[joel]

I tried to record a macro to expand the subtotals and no code wa
recorded. Wouldn't it be simplier to just expand the subtotals onc
before you run the macro?

 

[jc]

That worked no problem.
Thanks Joel

JC

 

[Duane]

Joel, Your code worked great last month , This month I get an "error 1
TypeMismatch" when I try to run my macro. here is my code the erro
occurs at "If InStr(UCase(.Range("b" & RowCount)), "Total") > 0 Then"



'*********NOTE ADD "TOTAL" TO COLUMN "A" BEFORE EXPANDING AND RUNNIN
THIS MACRO**********************
'ADDITIONAL NOTES CECK COLUMN FOR CONTRACTOR AND COUNT , ELIMINAT
ILLEGAL CHARACTERS IN CONTRACTOR NAMES BEFORE RUNNING

'change directory
Folder = "h:\Contractor Expired\Contractor Expired Apr2010\"
'Folder = "\\dpd-sharepoint\electrical\Contractor Expire
Spreadsheets\April2010"

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

Set Sourcesht = ThisWorkbook.Sheets("Expired")

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

StartRow = 2
RowCount = StartRow
For RowCount = StartRow To LastRow
' Application.IsError (CellValue)
If InStr(UCase(.Range("b" & RowCount)), "Total") > 0 Then
client = .Range("H" & 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.Active
newbook.SaveAs Filename:=Folder & client
FormatContractorList 'macro that hides some columns in new WB
newbook.Close savechanges:=True
End If
Next RowCount

End With

End Sub


Thank You again for your help
Duane






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

 

[joel]

The only reason I can see for the instruction to give an error is i
you had a formula in column b that produced an Error. Se if this chang
help you find the problem

'from
For RowCount = StartRow To LastRow
' Application.IsError (CellValue)
If InStr(UCase(.Range("b" & RowCount)), "Total") > 0 Then

'To
For RowCount = StartRow To LastRow
If WorksheetFunction.IsError("Expired!B" & RowCount)) Then
MsgBox ("Error in Cell : B" & RowCount & vbCrLf & _
"Exiting Macro")
Exit Sub
End If
' Application.IsError (CellValue)
If InStr(UCase(.Range("b" & RowCount)), "Total") > 0 Then