Option Explicit
Option Base 1
Sub CreateTotals()
' hiker95, 06/28/2010, http://www.mrexcel.com/forum/showthread.php?t=476824
Dim SR As Long, ER As Long, LR As Long, a As Long
Dim ws As Worksheet, wsAry
Dim c As Range, firstaddress As String, GTotC As String
Application.ScreenUpdating = False
wsAry = Array("CompA_US", "CompA_CA", "CompB_US", "CompB_CA")
With ThisWorkbook
For a = LBound(wsAry) To UBound(wsAry)
Set ws = Sheets(wsAry(a))
firstaddress = "": GTotC = "": SR = 0: ER = 0: LR = 0
GTotC = "=Sum("
With ws.Columns(2)
Set c = .Find("Total", LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
SR = Application.Match(c.Offset(-1, -1), ws.Columns(1), 0)
ER = c.Row - 1
c.Offset(, 1).Formula = "=SUM(C" & SR & ":C" & ER & ")"
c.Offset(, 1).AutoFill Destination:=ws.Range("C" & c.Row & ":J" & c.Row)
GTotC = GTotC & "C" & c.Row & ","
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
LR = ws.Cells(Rows.Count, 1).End(xlUp).Row
If Right(GTotC, 1) = "," Then
GTotC = Left(GTotC, Len(GTotC) - 1) & ")"
End If
ws.Range("C" & LR).Formula = GTotC
ws.Range("C" & LR).AutoFill Destination:=ws.Range("C" & LR & ":J" & LR)
Next a
End With
Application.ScreenUpdating = True
End Sub