Macro to loop based on cell value to sum varying size of rows

[esSant593]

I need help to develop a looping macro formula to sum range of varying size of rows based on cell value ‘Total’ in column B. The sample data are downloaded with amount on Totals but not formula. The help I need is to develop formula on each row with 'Total' in column C then copy them to last column of the same row, however, need to loop on each row with ‘Total’. If you need sample file let me know.

 

[esSant593]

The worksheet names:
CompA_US
CompA_CA
CompB_US
CompB_CA
The workbook name - Company XYZ

 

[hiker95]

esSant593,


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Adding the Macro
1. Copy the below macro, by highlighting the macro code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

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

Then run the "CreateTotals" in your workbook with the 4 worksheets per your last post.

 

[esSant593]

Thank you very much for sharing your expertise with your professionally written code. The macro is working perfectly that provided me an output that save me a lot of time.

 

[esSant593]

A big thank you to hiher95. What do I need to do say that this post is solved?

 

[hiker95]

esSant593,

The macro is working perfectly that provided me an output that save me a lot of time.

How much time do you think my macro will save you in hours per day/week/month?

What do I need to do say that this post is solved?

On the MrExcel forum this is not required.

Thanks for the good words, and, come back anytime.

 

[esSant593]

Your macro will save me between 45 to 60 minutes every time I have to do the reports (twice a month). I was able to modify your professionally written macro to perform unlimited number of columns and rows. Thank you again.