Option Explicit
Sub CreateTotals()
' hiker95, 06/25/2010, http://www.mrexcel.com/forum/showthread.php?t=476824
Dim SR As Long, ER As Long, LR As Long
Dim c As Range, firstaddress As String, GTotC As String
Application.ScreenUpdating = False
GTotC = "=Sum("
With 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), Columns(1), 0)
ER = c.Row - 1
c.Offset(, 1).Formula = "=SUM(C" & SR & ":C" & ER & ")"
c.Offset(, 1).AutoFill Destination:=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 = Cells(Rows.Count, 1).End(xlUp).Row
If Right(GTotC, 1) = "," Then
GTotC = Left(GTotC, Len(GTotC) - 1) & ")"
End If
Range("C" & LR).Formula = GTotC
Range("C" & LR).AutoFill Destination:=Range("C" & LR & ":J" & LR)
Application.ScreenUpdating = True
End Sub