View Single Post
  #4   Report Post  
Posted to microsoft.public.excel.programming
OssieMac OssieMac is offline
external usenet poster
 
Posts: 2,510
Default Subtotal for same range of multiple worksheets

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("A1:p900").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


--
Regards,

OssieMac