VBA Script Example

In this example, we decided to have the VBA script write the formula to add cells from three separate worksheets. The reason for writing the formula is that if any corrections are made to any source/ monthly sheets, it will automatically roll up without rerunning the Script.

This VBA Script Example will place a formula similar to: “=’JAN 2023′!H6+’FEB 2023′!H6+’MAR 2023′!H6 in the H6 cell on the quarterly roll up sheet. Some cells are not rolled up as they contain static data, or formulas already.

VBA Script Example showing the Excel Menu Sheet — User-defined Quarter and Year and the run button

Here is the VBA Script used

Public Sub QuarterRollUp()
‘ credit Business Software Systems, 2023

Dim Q(4)

‘ QuarterRollUp Macro
‘
Workbooks(“P&L_Consolidator.xlsm”).Activate
‘ The Commands worksheet contains values that are user define
Worksheets(“Commands”).Activate
‘ in this case the user sets the Quater and the year to roll up
Quarter = Range(“E31”).Value
Yr = Range(“E32”).Value
‘ We then define the Array Varriables for Q(x)
If Quarter = 1 Then
Q(1) = “Jan ” & Yr
Q(2) = “Feb ” & Yr
Q(3) = “Mar ” & Yr
FileDir = “03 ” & Q(3)
ElseIf Quarter = 2 Then
Q(1) = “Apr ” & Yr
Q(2) = “May ” & Yr
Q(3) = “Jun ” & Yr
FileDir = “06 ” & Q(3)
ElseIf Quarter = 3 Then
Q(1) = “Jul ” & Yr
Q(2) = “Aug ” & Yr
Q(3) = “Sep ” & Yr
FileDir = “09 ” & Q(3)
ElseIf Quarter = 4 Then
Q(1) = “Oct ” & Yr
Q(2) = “Nov ” & Yr
Q(3) = “Dec ” & Yr
FileDir = “12 ” & Q(3)
End If

' now open the P&L Master that contains the monthly P&L sheets
Workbooks.Open FileName:="O:' now open the P&L Master that contains the monthly P&L sheets
Workbooks.Open FileName:="O:\0 P&L DOWNLOAD\" & FileDir & "\MASTER COMPARATIVE REPORT\P&L Master.xlsx"
Workbooks("P&L Master.xlsx").Activate

' CHECK IF QUARTERLY TAB EXISTS
If sheetExists("Q" & Quarter & " " & Yr) Then
    CarryOn = MsgBox("Do you want to Delete Existing sheet?", vbYesNo)
    If CarryOn = vbYes Then
        Sheets("Q" & Quarter & " " & Yr).Delete
        Sheets(Q(3)).Copy After:=Sheets(Q(3))
        ActiveSheet.Name = "Q" & Quarter & " " & Yr
    Else
        ' Activate sheet and continue
        ActiveSheet.Name = "Q" & Quarter & " " & Yr
    End If
Else
    Sheets(Q(3)).Copy After:=Sheets(Q(3))
    ActiveSheet.Name = "Q" & Quarter & " " & Yr
End If
' Now look through the data to put the summing formula into just specific cells
    For ColNum = 8 To 248 Step 8
        For RowNum = 2 To 144
                Select Case RowNum
                    Case 2
                        Range(Cells(2, ColNum), Cells(2, ColNum)) = "Q" & Quarter & " " & Yr
                        Range(Cells(2, ColNum + 1), Cells(2, ColNum + 1)) = "Q" & Quarter & " " & Yr - 1
                        RowNum = 5
                    Case 11, 15, 20, 21, 31, 40, 43, 67, 81, 92, 110, 121, 127, 128, 132, 135, 136, 141
                            ' do Nothing
                    Case 142
                        ' do nothing its the last row
                    Case Else
                        CellNm = Cells(RowNum, ColNum).Address(RowAbsolute:=False, ColumnAbsolute:=False)
                        Range(Cells(RowNum, ColNum), Cells(RowNum, ColNum)).Value = "='" & Q(1) & "'!" & CellNm & "+'" & Q(2) & "'!" & CellNm & "+'" & Q(3) & "'!" & CellNm
                        CellNm = Cells(RowNum, ColNum + 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
                        Range(Cells(RowNum, ColNum + 1), Cells(RowNum, ColNum + 1)).Value = "='" & Q(1) & "'!" & CellNm & "+'" & Q(2) & "'!" & CellNm & "+'" & Q(3) & "'!" & CellNm
                End Select
        Next
   Next
EndSub P&L DOWNLOAD\" & FileDir & "\MASTER COMPARATIVE REPORT\P&L Master.xlsx"
Workbooks("P&L Master.xlsx").Activate

' CHECK IF QUARTERLY TAB EXISTS
If sheetExists("Q" & Quarter & " " & Yr) Then
    CarryOn = MsgBox("Do you want to Delete Existing sheet?", vbYesNo)
    If CarryOn = vbYes Then
        Sheets("Q" & Quarter & " " & Yr).Delete
        Sheets(Q(3)).Copy After:=Sheets(Q(3))
        ActiveSheet.Name = "Q" & Quarter & " " & Yr
    Else
        ' Activate sheet and continue
        ActiveSheet.Name = "Q" & Quarter & " " & Yr
    End If
Else
    Sheets(Q(3)).Copy After:=Sheets(Q(3))
    ActiveSheet.Name = "Q" & Quarter & " " & Yr
End If
' Now look through the data to put the summing formula into just specific cells
    For ColNum = 8 To 248 Step 8
        For RowNum = 2 To 144
                Select Case RowNum
                    Case 2
                        Range(Cells(2, ColNum), Cells(2, ColNum)) = "Q" & Quarter & " " & Yr
                        Range(Cells(2, ColNum + 1), Cells(2, ColNum + 1)) = "Q" & Quarter & " " & Yr - 1
                        RowNum = 5
                    Case 11, 15, 20, 21, 31, 40, 43, 67, 81, 92, 110, 121, 127, 128, 132, 135, 136, 141
                            ' do Nothing
                    Case 142
                        ' do nothing its the last row
                    Case Else
                        CellNm = Cells(RowNum, ColNum).Address(RowAbsolute:=False, ColumnAbsolute:=False)
                        Range(Cells(RowNum, ColNum), Cells(RowNum, ColNum)).Value = "='" & Q(1) & "'!" & CellNm & "+'" & Q(2) & "'!" & CellNm & "+'" & Q(3) & "'!" & CellNm
                        CellNm = Cells(RowNum, ColNum + 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
                        Range(Cells(RowNum, ColNum + 1), Cells(RowNum, ColNum + 1)).Value = "='" & Q(1) & "'!" & CellNm & "+'" & Q(2) & "'!" & CellNm & "+'" & Q(3) & "'!" & CellNm
                End Select
        Next
   Next
EndSub

‘ This function is used to check if the Quarterly roll up sheet already exists
Function sheetExists(sheetToFind As String) As Boolean
sheetExists = False
For Each Sheet In Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function