Prev: Insert Picture using Macro
Next: To prevent a user from deleting and renaming a sheet in a workbook
From: jc on 6 Apr 2010 21:46
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 7 Apr 2010 06:48

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 7 Apr 2010 13:59
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 7 Apr 2010 14:46

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 7 Apr 2010 17:49
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
 |  Next  |  Last
Pages: 1 2
Prev: Insert Picture using Macro
Next: To prevent a user from deleting and renaming a sheet in a workbook