Good way to create quarter, half year and year summary formulas in Excel using VBA?

Question

I have a calendar bar in a document that has the same layout as the image. The calendar is copied from Power Pivot, but I want to calculate the quarter, half year and year cells using formulas. I want to create these formulas using VBA. Is there any clever way to do this?

The calendar can start and end on any month and year. The quarters, half years and years are not always complete, meaning the full 3, 6 or 12 months are not always included in the calendar.

My best idea is to loop over all columns three times. The first time, building up a SUM formula month by month until landing on a year column and then writing the formula to that column. The next time, doing in the same for half-year columns. The third time, doing the same for quarter columns. But that seems too complicated to do something this simple.

Answer 1

You only need to run the loop once, as is in the code below. I've had a guess at the functions and variables that you haven't included in the code so here's the whole module:

Option Explicit
Private Enum CellType
    Unknown
    Month
    Quarter
    Half
    Year
End Enum
Private Const YEAR_ROW As Long = 1
Private Const HALF_ROW As Long = 2
Private Const QUARTER_ROW As Long = 3
Private Const MONTH_ROW As Long = 4
Private Const FIRST_VALUE_ROW As Long = 5
Private mWS As Worksheet
Private mRowCount As Long

Sub RunMe()
    Dim ws As Worksheet
    Dim lastCol As Long
    Dim c As Long
    Dim quarterRange As Range
    Dim halfRange As Range
    Dim yearRange As Range


    Set mWS = ThisWorkbook.Worksheets("Sheet1") '~~> amend as necessary

    mRowCount = mWS.Cells.Find(What:="*", _
                               After:=mWS.Cells(1), _
                               Lookat:=xlPart, _
                               LookIn:=xlFormulas, _
                               SearchOrder:=xlByRows, _
                               SearchDirection:=xlPrevious, _
                               MatchCase:=False).Row - FIRST_VALUE_ROW

    lastCol = mWS.Cells(YEAR_ROW, mWS.Columns.Count).End(xlToLeft).Column

    For c = 1 To lastCol

        Select Case GetCellType(c)
            Case CellType.Month
                Set quarterRange = Unionised(quarterRange, c)
            Case CellType.Quarter
                Set halfRange = Unionised(halfRange, c)
                Set quarterRange = FilledAndCleared(quarterRange, c)
            Case CellType.Half
                Set yearRange = Unionised(yearRange, c)
                Set halfRange = FilledAndCleared(halfRange, c)
            Case CellType.Year
                Set yearRange = FilledAndCleared(yearRange, c)

        End Select

    Next
End Sub

Private Function GetCellType(c As Long) As CellType
    Dim content As String

    If Len(CStr(mWS.Cells(MONTH_ROW, c).Value2)) > 0 Then GetCellType = CellType.Month: Exit Function
    If InStr(CStr(mWS.Cells(QUARTER_ROW, c).Value2), "Total") > 0 Then GetCellType = CellType.Quarter: Exit Function
    If InStr(CStr(mWS.Cells(HALF_ROW, c).Value2), "Total") > 0 Then GetCellType = CellType.Half: Exit Function
    If InStr(CStr(mWS.Cells(YEAR_ROW, c).Value2), "Total") > 0 Then GetCellType = CellType.Year: Exit Function
    GetCellType = CellType.Unknown

End Function

Private Function Unionised(oldRng As Range, c As Long) As Range
    If oldRng Is Nothing Then
        Set Unionised = mWS.Cells(FIRST_VALUE_ROW, c)
    Else
        Set Unionised = Union(oldRng, mWS.Cells(FIRST_VALUE_ROW, c))
    End If
End Function

Private Function FilledAndCleared(rng As Range, c As Long) As Range
    Dim i As Long

    For i = 0 To mRowCount
        rng.Worksheet.Cells(FIRST_VALUE_ROW + i, c).Formula = "=SUM(" & rng.Offset(i).Address(False, False) & ")"
    Next
    Set FilledAndCleared = Nothing
End Function

Answer 2

My answer will work if the Months and Sums are set according to the image below (which I got from your image).

Sub SomeSub()
Dim r As Long
Dim LastRow As Long

With ActiveSheet.UsedRange
    'Getting the last Row of the used range
    LastRow = .Rows(.Rows.Count).Row - 1
End With

'Loop for the rows of data
For r = 5 To LastRow

    'Quarter Calculation
    'Quarter 1
    Range("D" & r).Value = Application.WorksheetFunction.Sum(Range("A" & r), Range("B" & r), Range("C" & r))
    'Quarter 2
    Range("H" & r).Value = Application.WorksheetFunction.Sum(Range("E" & r), Range("F" & r), Range("G" & r))
    'Quarter 3
    Range("Q" & r).Value = Application.WorksheetFunction.Sum(Range("J" & r), Range("K" & r), Range("K" & r))
    'Quarter 4
    Range("M" & r).Value = Application.WorksheetFunction.Sum(Range("N" & r), Range("O" & r), Range("P" & r))

    'Bi Annual Calculation
    'First 6 Months
    Range("I" & r).Value = Application.WorksheetFunction.Sum(Range("A" & r), Range("B" & r), Range("C" & r), _
                                                             Range("E" & r), Range("F" & r), Range("G" & r))
    'Second 6 Months
    Range("R" & r).Value = Application.WorksheetFunction.Sum(Range("J" & r), Range("K" & r), Range("K" & r), _
                                                             Range("N" & r), Range("O" & r), Range("P" & r))

    'Year Calculation
    Range("S" & r).Value = Application.WorksheetFunction.Sum(Range("A" & r), Range("B" & r), Range("C" & r), _
                                                             Range("E" & r), Range("F" & r), Range("G" & r), _
                                                             Range("J" & r), Range("K" & r), Range("K" & r), _
                                                             Range("N" & r), Range("O" & r), Range("P" & r))

Next


End Sub

EDIT

Considering the OP comment that the Quarters may not always have 3 months, first the Quarter Ranges need to be determined.

See new script below:

Sub SomeOtherSub()

Dim YrStart As Long, YrEnd As Long
Dim H1Start As Long, H1End As Long
Dim H2Start As Long, H2End As Long
Dim Q1Start As Long, Q1End As Long, Q1T As Long
Dim Q2Start As Long, Q2End As Long, Q2T As Long
Dim Q3Start As Long, Q3End As Long, Q3T As Long
Dim Q4Start As Long, Q4End As Long, Q4T As Long
Dim LastRow As Long
Dim col As Long

With ActiveSheet.UsedRange
    'Getting the last Colunm of the used range
    LastColumn = .Columns(.Columns.Count).Column
End With

'InStr() = 0 means that the text is not included in the string
'InStr() > 0 means that the text is included in the string

'Getting the Ranges for each Quarter
For col = 1 To LastColumn
    aa = Cells(3, col)
    If InStr(aa, "Q1") > 0 And InStr(aa, "Total") = 0 Then Q1Start = col
    If InStr(aa, "Q1") > 0 And InStr(aa, "Total") > 0 Then
        Q1End = col - 1  ' -1 for the end of the data for the quarter
        Q1T = col
    End If
    If InStr(aa, "Q2") > 0 And InStr(aa, "Total") = 0 Then Q2Start = col
    If InStr(aa, "Q2") > 0 And InStr(aa, "Total") > 0 Then
        Q2End = col ' -1 for the end of the data for the quarter
        Q2T = col
    End If
    If InStr(aa, "Q3") > 0 And InStr(aa, "Total") = 0 Then Q3Start = col
    If InStr(aa, "Q3") > 0 And InStr(aa, "Total") > 0 Then
        Q3End = col - 1 ' -1 for the end of the data for the quarter
        Q3T = col
    End If
    If InStr(aa, "Q4") > 0 And InStr(aa, "Total") = 0 Then Q4Start = col
    If InStr(aa, "Q4") > 0 And InStr(aa, "Total") > 0 Then
        Q4End = col - 1 ' -1 for the end of the data for the quarter
        Q4T = col
    End If
Next

'Getting the Ranges for each Bi Annual
For col = 1 To LastColumn
    aa = Cells(2, col)
    If InStr(aa, "H1") > 0 And InStr(aa, "Total") = 0 Then H1Start = col
    If InStr(aa, "H1") > 0 And InStr(aa, "Total") > 0 Then H1T = col
    If InStr(aa, "H2") > 0 And InStr(aa, "Total") = 0 Then H2Start = col
    If InStr(aa, "H2") > 0 And InStr(aa, "Total") > 0 Then H2T = col
Next

'Getting the Ranges for the year
For col = 1 To LastColumn
    aa = Cells(1, col)
    If Len(aa) > 0 And InStr(aa, "Total") = 0 Then YrStart = col
    If Len(aa) > 0 And InStr(aa, "Total") > 0 Then YrT = col
Next

With ActiveSheet.UsedRange
    'Getting the last Row of the used range
    LastRow = .Rows(.Rows.Count).Row - 1
End With


'Loop for the rows of data
For r = 5 To LastRow


    'Quarter Calculation
    'Quarter 1
    Cells(r, Q1T).Value = Application.WorksheetFunction.Sum(Range(Cells(r, Q1Start), Cells(r, Q1End)))
    'Quarter 2
    Cells(r, Q2T).Value = Application.WorksheetFunction.Sum(Range(Cells(r, Q2Start), Cells(r, Q2End)))
    'Quarter 3
    Cells(r, Q3T).Value = Application.WorksheetFunction.Sum(Range(Cells(r, Q3Start), Cells(r, Q3End)))
    'Quarter 4
    Cells(r, Q4T).Value = Application.WorksheetFunction.Sum(Range(Cells(r, Q4Start), Cells(r, Q4End)))

    'Bi Annual Calculation
    'First 6 Months
    Cells(r, H1T).Value = Application.WorksheetFunction.Sum(Cells(r, Q1T), Cells(r, Q2T))
    'Second 6 Months
    Cells(r, H2T).Value = Application.WorksheetFunction.Sum(Cells(r, Q3T), Cells(r, Q4T))

    'Year Calculation
    Cells(r, YrT).Value = Application.WorksheetFunction.Sum(Cells(r, H1T), Cells(r, H2T))

Next

End Sub

Answer 3

This is how I solved it. I would welcome a significantly simpler solution.

'Year
sFormula = ""
For c = 6 To LastColumn(wksTarget)
    If wksTarget.Cells(lMonthsRow, c) <> "" Then
        sFormula = sFormula & "+" & wksTarget.Cells(lFirstItemRow, c).Address(RowAbsolute:=False, ColumnAbsolute:=False)
    End If
    If wksTarget.Cells(lMonthsRow, c) = "" And InStr(1, wksTarget.Cells(lYearsRow, c), "Total") Then
        wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)) = "=" & sFormula
        Call FormatAsTotal(wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)))
        sFormula = ""
    End If
Next

'Half year
sFormula = ""
For c = 6 To LastColumn(wksTarget)
    If wksTarget.Cells(lMonthsRow, c) <> "" Then
        sFormula = sFormula & "+" & wksTarget.Cells(lFirstItemRow, c).Address(RowAbsolute:=False, ColumnAbsolute:=False)
    End If
    If wksTarget.Cells(lMonthsRow, c) = "" And InStr(1, wksTarget.Cells(lHalfYearsRow, c), "Total") Then
        wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)) = "=" & sFormula
        Call FormatAsSubtotal(wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)))
        sFormula = ""
    End If
Next

'Quarter
sFormula = ""
For c = 6 To LastColumn(wksTarget)
    If wksTarget.Cells(lMonthsRow, c) <> "" Then
        sFormula = sFormula & "+" & wksTarget.Cells(lFirstItemRow, c).Address(RowAbsolute:=False, ColumnAbsolute:=False)
    End If
    If wksTarget.Cells(lMonthsRow, c) = "" And InStr(1, wksTarget.Cells(lQuartersRow, c), "Total") Then
        wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)) = "=" & sFormula
        Call FormatAsSubtotal(wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)))
        sFormula = ""
    End If
Next