Subtotal for same range of multiple worksheets

[PHisaw]

Hi,

I have a workbook where data is compiled through out the year and has to be
re-ran from the beginning of the year each month due to changes in open
orders. I also have worksheets breaking down each month, but it has become a
problem recreating the worksheets each month. I have code (from Ron de
Bruin) to create a worksheet for each month ("01-09", "02-09", etc.). Now, I
want to save the workbook (ActiveWorkbook.Save) after the pages are created
and run the following code for worksheets named 01-09, 02-09, etc. This will
work for one worksheet, but I can't seem to find the right code to make it
work for an array of worksheets.
It will sort and subtotal specified columns and then bold total rows and
insert a row after each total row.

Sub Total_Worksheets()

Dim rng As Range

Range("A1900").Select
Selection.Sort Key1:=Range("c2"), Order1:=xlAscending, _
Key2:=Range("A2"), Order2:=xlAscending, _
Key2:=Range("b2"), Order2:=xlAscending, _
Header:=xlYes

With Sheets("02-09")

On Error Resume Next
Set rng = Range(Range("j2"), Cells(2, Columns.Count).End(xlToLeft))
On Error GoTo 0
If Not rng Is Nothing Then

.Range("j2").Subtotal _
GroupBy:=3, _
Function:=xlSum, _
TotalList:=Array(10, 11, 12), _
Replace:=False, _
PageBreaks:=False, _
SummaryBelowData:=True

.Range("j2").Subtotal _
GroupBy:=1, _
Function:=xlSum, _
TotalList:=Array(10, 11, 12), _
Replace:=False, _
PageBreaks:=False, _
SummaryBelowData:=True

.Range("j2").Subtotal _
GroupBy:=2, _
Function:=xlSum, _
TotalList:=Array(10, 11, 12), _
Replace:=False, _
PageBreaks:=False, _
SummaryBelowData:=True

End If
End With

Dim LastRow As Long
Dim r As Long
LastRow = Range("G" & Rows.Count).End(xlUp).Row
For r = LastRow To 2 Step -1
If InStr(1, Cells(r, 1).Value, "Total") > 0 Or _
InStr(1, Cells(r, 2).Value, "Total") > 0 Or _
InStr(1, Cells(r, 3).Value, "Total") > 0 Or _
InStr(1, Cells(r, 4).Value, "Total") > 0 Then
Range(Cells(r, 1), Cells(r, 30)).Font.Bold = True
ActiveSheet.Rows(r + 1).EntireRow.Insert
End If
Next

End Sub

If this is possible to do over multiple sheets, I would really appreciate
code to make it work.
Thanks in advance,
Phisaw

 

[OssieMac]

Try the following. Code is untested. Backup your workbook first and note the
comments in the code.


Sub Total_Worksheets()

Dim ws As Worksheet
Dim rng As Range

'If you want to select a range, ensure the correct
'worksheet is selected first or it will have errors
'because it selects on the currently active worksheet.
'Edit SheetName to your sheet name.
Sheets("SheetName").Select
'or
'Sheets ws.Select 'See next comment

Range("A1900").Select
Selection.Sort Key1:=Range("c2"), Order1:=xlAscending, _
Key2:=Range("A2"), Order2:=xlAscending, _
Key2:=Range("b2"), Order2:=xlAscending, _
Header:=xlYes

'Not sure if the following line needs to be before
'or after the previous code.
For Each ws In Worksheets

'Could insert an if statement here like the
'following to exclude any specific worksheets
'If ws.Name = "MainMenu" Or ws.Name = "Totals" Then
' GoTo SkipSheet
'End If

'With Sheets("02-09") 'Use next line in lieu
With ws

On Error Resume Next
Set rng = Range(Range("j2"), Cells(2, Columns.Count).End(xlToLeft))
On Error GoTo 0
If Not rng Is Nothing Then

.Range("j2").Subtotal _
GroupBy:=3, _
Function:=xlSum, _
TotalList:=Array(10, 11, 12), _
Replace:=False, _
PageBreaks:=False, _
SummaryBelowData:=True

.Range("j2").Subtotal _
GroupBy:=1, _
Function:=xlSum, _
TotalList:=Array(10, 11, 12), _
Replace:=False, _
PageBreaks:=False, _
SummaryBelowData:=True

.Range("j2").Subtotal _
GroupBy:=2, _
Function:=xlSum, _
TotalList:=Array(10, 11, 12), _
Replace:=False, _
PageBreaks:=False, _
SummaryBelowData:=True

End If
End With

Dim LastRow As Long
Dim r As Long
LastRow = Range("G" & Rows.Count).End(xlUp).Row
For r = LastRow To 2 Step -1
If InStr(1, Cells(r, 1).Value, "Total") > 0 Or _
InStr(1, Cells(r, 2).Value, "Total") > 0 Or _
InStr(1, Cells(r, 3).Value, "Total") > 0 Or _
InStr(1, Cells(r, 4).Value, "Total") > 0 Then
Range(Cells(r, 1), Cells(r, 30)).Font.Bold = True
ActiveSheet.Rows(r + 1).EntireRow.Insert
End If
Next

'SkipSheet: 'Uncomment if using skip worksheets
Next ws

End Sub

 

[OssieMac]

The following should do what you want. I now see I had a couple of errors in
my previous code but perhaps you picked them up. As before, the code is
untested but I did at least compile it this time.

The Select Case is a better way than if statements to select from a list of
sheets. So easy to just edit the list of sheet names.

Sub Total_Worksheets()

Dim ws As Worksheet
Dim rng As Range

For Each ws In Worksheets

Select Case ws.Name

'All sheet names listed in the case statement
'will be processed. Change the names I have
'used to your sheet names and add your
'additional sheet names separated by commas.
Case "Sheet1", "Sheet2", "Sheet3", "Sheet4"

ws.Select

Range("A1900").Select
Selection.Sort Key1:=Range("c2"), _
Order1:=xlAscending, _
Key2:=Range("A2"), Order2:=xlAscending, _
Key2:=Range("b2"), Order2:=xlAscending, _
Header:=xlYes

On Error Resume Next
'Following line references active sheet so
'do not nest inside the With/End With
Set rng = Range(Range("j2"), _
Cells(2, Columns.Count).End(xlToLeft))
On Error GoTo 0

If Not rng Is Nothing Then

With ws
.Range("j2").Subtotal _
GroupBy:=3, _
Function:=xlSum, _
TotalList:=Array(10, 11, 12), _
Replace:=False, _
PageBreaks:=False, _
SummaryBelowData:=True

.Range("j2").Subtotal _
GroupBy:=1, _
Function:=xlSum, _
TotalList:=Array(10, 11, 12), _
Replace:=False, _
PageBreaks:=False, _
SummaryBelowData:=True

.Range("j2").Subtotal _
GroupBy:=2, _
Function:=xlSum, _
TotalList:=Array(10, 11, 12), _
Replace:=False, _
PageBreaks:=False, _
SummaryBelowData:=True
End With

End If

Dim LastRow As Long
Dim r As Long
'Following code references active sheet so
'do not nest inside the With/End With
LastRow = Range("G" & Rows.Count).End(xlUp).Row
For r = LastRow To 2 Step -1
If InStr(1, Cells(r, 1).Value, "Total") > 0 Or _
InStr(1, Cells(r, 2).Value, "Total") > 0 Or _
InStr(1, Cells(r, 3).Value, "Total") > 0 Or _
InStr(1, Cells(r, 4).Value, "Total") > 0 Then
Range(Cells(r, 1), Cells(r, 30)).Font.Bold = True
ActiveSheet.Rows(r + 1).EntireRow.Insert
End If
Next
End Select 'End of Case

Next ws

End Sub

 

[PHisaw]

OssieMac,

It works! Thank you soooooo much!!

I have one more piece of code that I can't quite get to work as I want.
Thanks to Jim Thomlinson, I used code he supplied to another poster but with
my modification to fit my spreadsheet there is just a cosmetic flaw I would
like to take care of. On the second part of the following code (for column
B) after I .resize (,15) it doesn't highlight column A. I can't choose
..entirerow, because I have other data past column P that I don't want
highlighted. What code do I use to have it highlight A when word "Total"
is in Column B?

Dim rngFound As Range
Dim strFirstAddress As String

'Search slsp for Total rows
Set rngFound = Columns("A").Find(What:="total", _
LookAt:=xlPart, _
LookIn:=xlValues, _
MatchCase:=False)
If Not rngFound Is Nothing Then
strFirstAddress = rngFound.Address
Do
rngFound.Resize(, 16).Interior.ColorIndex = 17
Set rngFound = Columns("A").FindNext(rngFound)
Loop Until rngFound.Address = strFirstAddress
End If

'Search Class for Total rows
Set rngFound = Columns("B").Find(What:="total", _
LookAt:=xlPart, _
LookIn:=xlValues, _
MatchCase:=False)
If Not rngFound Is Nothing Then
strFirstAddress = rngFound.Address
Do
rngFound.Resize(, 15).Interior.ColorIndex = 6
Set rngFound = Columns("B").FindNext(rngFound)
Loop Until rngFound.Address = strFirstAddress
End If

Thanks again for all your help,
Phisaw

 

[OssieMac]

Sorry I didn't get back to you sooner but I have been away. Anyway if you
have not already got your answer then try the following.

rngFound.Offset(0, -1).Resize(, 16).Interior.ColorIndex = 6

Another option is.

Range(Cells(rngFound.Row, "A"), _
Cells(rngFound.Row, "P")) _
.Interior.ColorIndex = 6