Using VBA, how can I SUM all the values from columns until I find column "Total"? Then do the same from next cell to next "total"? Then sum Totals in the Grand Total?

Question

I need help with a VBA code to  

1. I need to sum the values of each row and store them in the Total columns. Autofill down to the “Cost of Goods Sold Total” row. Loop to the next "Month" section and sum the values of each row and store them in the Total columns. The columns can change, so it's not the same before every "Total" column. Loop through until "Grand Total" column. In the grand total, sum the total of each section. Autofill down to the “Cost of Goods Sold Total” row.

    2.  Next, sum the columns, find first row with “\*Total” and create subtotal formula for the above values     ex.          =SUBTOTAL(9,B14:B25)  (the # rows for each section will change).  Autofill right to last column with data
   
    3. Loop to find the next row with “\*Total” and create subtotal formula, do until “Cost of Goods Sold Total” row  Loop through workbook, skip worksheet “Period” and “All”.  In the “Cost of Goods Sold Total”, sum the total of each section. 
   
   4 .  calculate the Gross Profit / (Loss) =  Total Revenue - Total Cost of Goods Sold.  The location of the Gross Profit / (Loss) will change as well.   
   

Here is what we have so far. I had someone help me to this step. I made some minor adjustments to their code. If you make suggestions that deviate too far from this code, you'll lose me.

---

Sub CalculateTotals()

'// Version 3 work on Totals columns and rows *** needs to be dynamic

Dim ws As Worksheet 

Dim lastCol As Long, lastRow As Long 

Dim currentCol As Long, currentRow As Long 

Dim totalCol As Collection 

Dim grandTotalCol As Long 

Dim colIndex As Variant 

Dim subtotalRow As Long 

' Loop through all worksheets in the workbook 

For Each ws In ThisWorkbook.Worksheets 

    If ws.Name <> "Period" And ws.Name <> "All" Then 

        lastCol = ws.Cells(4, ws.Columns.Count).End(xlToLeft).Column 

        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row 

        ' Initialize a collection to store the columns with "\*Total" 

        Set totalCol = New Collection 

        ' Find all columns with "\*Total" and prepare SUM formulas 

        For currentCol = 1 To lastCol 

            If ws.Cells(4, currentCol).Value Like "\*Total" Then 

                totalCol.Add currentCol 

                ' Overwrite and clear data in each relevant row starting from row x to "Cost of Goods Sold Total" row 

                For currentRow = 6 To lastRow 

                    If ws.Cells(currentRow, 1).Value Like "Cost of Goods Sold Total" Then Exit For 

                    ' Check if the current cell is part of a merged range 

                    If Not ws.Cells(currentRow, currentCol).MergeCells Then 

                        ws.Cells(currentRow, currentCol).ClearContents ' Clear existing data 

                        ws.Cells(currentRow, currentCol).Formula = "=SUM(" & ws.Cells(currentRow, currentCol - 2).Address & ":" & ws.Cells(currentRow, currentCol - 1).Address & ")" 

                    End If 

                Next currentRow 

            End If 

        Next currentCol 

        ' Find the column labeled "Grand Total" 

        For currentCol = 1 To lastCol 

            If ws.Cells(1, currentCol).Value Like "\*Grand Total\*" Then 

                grandTotalCol = currentCol 

                Exit For 

            End If 

        Next currentCol 

        ' Create GRAND TOTAL formula and clear existing data 

        If grandTotalCol > 0 Then 

            For currentRow = 2 To lastRow 

                If ws.Cells(currentRow, 1).Value Like "Cost of Goods Sold Total" Then Exit For 

                Dim totalSum As String 

                totalSum = "" 

                ' Loop through each "\*Total" column and sum them for the Grand Total, excluding the Grand Total column itself 

                For Each colIndex In totalCol 

                    If colIndex <> grandTotalCol Then 

                        If totalSum <> "" Then totalSum = totalSum & "+" 

                        totalSum = totalSum & ws.Cells(currentRow, colIndex).Address 

                    End If 

                Next colIndex 

                ' Check if the current cell is part of a merged range 

                If Not ws.Cells(currentRow, grandTotalCol).MergeCells Then 

                    ws.Cells(currentRow, grandTotalCol).ClearContents ' Clear existing data 

                    ws.Cells(currentRow, grandTotalCol).Formula = "=" & totalSum 

                End If 

            Next currentRow 

        End If 

        ' Find the first row with "\*Total" for SUBTOTAL and clear existing data 

        For currentRow = 1 To lastRow 

            If ws.Cells(currentRow, 1).Value Like "\*Total" Then 

                subtotalRow = currentRow 

                ' Check if the current cell is part of a merged range 

                If Not ws.Cells(currentRow, 2).MergeCells Then 

                    ws.Cells(currentRow, 2).ClearContents ' Clear existing data 

                    ws.Cells(currentRow, 2).Formula = "=SUBTOTAL(9," & ws.Cells(currentRow - 1, 1).End(xlUp).Address & ":" & ws.Cells(currentRow - 1, 1).Address & ")" 

                End If 

                ' Autofill right to last column with data, clearing existing data first 

                For currentCol = 2 To lastCol 

                    If Not ws.Cells(currentRow, currentCol).MergeCells Then 

                        ws.Cells(currentRow, currentCol).ClearContents ' Clear existing data 

                        ws.Cells(currentRow, currentCol).Formula = "=SUBTOTAL(9," & ws.Cells(currentRow - 1, currentCol).End(xlUp).Address & ":" & ws.Cells(currentRow - 1, currentCol).Address & ")" 

                    End If 

                Next currentCol 

            End If 

        Next currentRow 

    End If 

Next ws 

MsgBox "Totals and subtotals calculated!" 

End Sub

Windows, Excel 360

Answer 1

Your code is Amazing!

the "...Total" fill right step changes the formatting of the total columns. Is there a fix to prevent the change in formatting?

Thank you.

As we have relative formulas in the cells, we can write the formulas in the cells instead of fill them to the right.

Change the line in sub MyFillRight
Area.Resize(, Till.Column - All.Column + 1).FillRight

to
Area.Resize(, Till.Column - All.Column + 1).Formula = Area.Formula

Andreas.

Answer 2

Copy the code below into a regular module in your sample file and run sub Main.

These are the correct formulas IMHIO...

Andreas.

Option Explicit
Option Compare Text

Private Const SubTotalFormula = "=SUBTOTAL(9, @Range)"
Private Const TotalFormula = "=SUM(@Range)"

Sub Main()
Dim F As Range, T As Range
Dim RTotal As Range, OTotal As Range, GTotal As Range
Dim All As Range, Area As Range

Set GTotal = Cells.Find("Grand Total", LookIn:=xlValues, LookAt:=xlWhole)
ClearAllTotals GTotal

'Find the Revenue section
Set F = Range("A:A").Find("Revenue", LookIn:=xlValues, LookAt:=xlPart)
Set T = Range("A:A").Find("Revenue", SearchDirection:=xlPrevious)
Set All = ProcessSections(Range(F, T), RTotal)
MyFillRight All, GTotal

'All other sections are below the Revenue section
Set F = T.Offset(1)
Set T = Range("A" & Rows.Count).End(xlUp)
Set All = ProcessSections(Range(F, T), OTotal)
MyFillRight All, GTotal

'Process Profit/Loss
Const PLFormula = "=@R-@O"
Dim Formula As String
Formula = PLFormula
Formula = Replace(Formula, "@R", RTotal.Address(0, 0))
Formula = Replace(Formula, "@O", OTotal.Address(0, 0))
Set All = T.Offset(, 1)
All.Formula = Formula
MyFillRight All, GTotal

'Process the year totals
Set F = Range("A" & GTotal.Row).End(xlToRight)
Set T = GTotal.Offset(, -1)
Set All = ProcessYears(Range(F, T))
'Process the grand total
For Each Area In Intersect(All.EntireRow, GTotal.EntireColumn)
Area.Formula = Replace(TotalFormula, "@Range", Intersect(All.EntireColumn, Area.EntireRow).Address(0, 0))
Next
End Sub

Private Sub MyFillRight(ByRef All As Range, ByRef Till As Range)
'Just to keep code simple
Dim Area As Range
For Each Area In All.Areas
Area.Resize(, Till.Column - All.Column + 1).FillRight
Next
End Sub

Private Sub MyUnion(ByRef Dest As Range, ByRef This As Range)
'Just to keep code simple
If Dest Is Nothing Then Set Dest = This Else Set Dest = Union(Dest, This)
End Sub

Private Function ProcessSections(ByVal Where As Range, ByRef Total As Range) As Range
Dim SubTotal As Range, SubTotals As Range
Dim FirstAddress As String
Dim F As Range, T As Range, Here As Range

'Find the first sub total row
Set Here = Where.Find("*Total", LookIn:=xlValues, LookAt:=xlWhole)
'Remember this row
FirstAddress = Here.Address
Do
'The start is the same content without "Total" anywhere above
Set F = Where.Find(Trim(Left(Here, Len(Here) - 5)), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious)
'Refer to the data cells
Set F = Intersect(Where.Offset(, 1), F.Offset(1).EntireRow)
Set T = Intersect(Where.Offset(, 1), Here.Offset(-1).EntireRow)
Set SubTotal = Intersect(Where.Offset(, 1), Here.EntireRow)
'Create the formula
SubTotal.Formula = Replace(SubTotalFormula, "@Range", Range(F, T).Address(0, 0))
'Remember this cell
MyUnion SubTotals, SubTotal
MyUnion ProcessSections, SubTotal

'Assume a Total below  
Set Total = SubTotal.Offset(1)  
'Is it there?  
If Intersect(Where, Total.EntireRow) Like "Total\*" Then  
  'Remember this cell  
  MyUnion ProcessSections, Total  
  'Create the formula  
  Total.Formula = Replace(TotalFormula, "@Range", SubTotals.Address(0, 0))  
End If  
'Find the next sub total row  
Set Here = Where.Find("\*Total", Here, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)  

Loop Until Here.Address = FirstAddress
End Function

Private Sub ClearAllTotals(ByRef GrandTotal As Range)
Dim FirstAddress As String
Dim Where As Range, Here As Range, F As Range, T As Range

'Clear all total rows
Set Where = Range("A:A")
Set Here = Where.Find("Total", LookIn:=xlValues, LookAt:=xlPart)
FirstAddress = Here.Address
Do
Set F = Here.Offset(, 1)
Set T = F.Offset(, Columns.Count - F.Column).End(xlToLeft)
If T.Column >= F.Column Then Range(F, T).ClearContents
Set Here = Where.Find("Total", Here, LookIn:=xlValues, LookAt:=xlPart)
Loop Until Here.Address = FirstAddress

'Clear all total columns
Set Where = GrandTotal.EntireRow
Set Here = Where.Find("Total", LookIn:=xlValues, LookAt:=xlPart)
FirstAddress = Here.Address
Do
Set F = Here.Offset(1)
Set T = F.Offset(Rows.Count - F.Row).End(xlUp)
If T.Row >= F.Row Then Range(F, T).ClearContents
Set Here = Where.Find("Total", Here, LookIn:=xlValues, LookAt:=xlPart)
Loop Until Here.Address = FirstAddress
End Sub

Private Function ProcessYears(ByVal Where As Range) As Range
Dim F As Range, T As Range, Here As Range, R As Range, Total As Range
Dim FirstAddress As String
'Find the first year total column
Set Here = Where.Find("*Total", LookIn:=xlValues, LookAt:=xlWhole)
FirstAddress = Here.Address
'The column on the right is the next data cell
Set F = Where.Cells(1)
Do
'In each row
For Each R In Range(Here.Offset(1), Here.Offset(Rows.Count - Here.Row).End(xlUp))
'Skip over our formulas
If R.HasFormula Then GoTo Skip
'Do we have a numbric value on the left side?
If Not IsNumeric(R.Offset(, -1)) Then GoTo Skip
If R.Offset(, -1) = "" Then GoTo Skip
'Yes, this is the place for the formula
Set Total = Intersect(Range(F, Here.Offset(, -1)).EntireColumn, R.EntireRow)
'Remember this cell
MyUnion ProcessYears, R
'Create the formula
R.Formula = Replace(TotalFormula, "@Range", Total.Address(0, 0))
Skip:
Next
'The next column on the right is the next data cell
Set F = Here.Offset(, 1)
'Find the next year total column
Set Here = Where.Find("*Total", Here, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
Loop Until Here.Address = FirstAddress
End Function

Answer 3

We need to see your (sample) file.
Why a sample file is important for troubleshooting. How to do it. - Microsoft Community

Andreas.

Answer 4

Here is the link to the sample file. WIP VBA Subtotals1 - Posted.xlsm

Answer 5

Your code is Amazing! The code worked remarkably on the sample file without any issues. Thank you so much.

Side note, when I created a new file and used the code, the "...Total" fill right step changes the formatting of the total columns. Is there a fix to prevent the change in formatting?