Every piece of business that gets written (E.G. an adviser's client puts an additional £10k payment into a pension plan) goes in a spreadsheet called the SubSheet. It's split into 8 worksheets for different kinds of business, each with lots and lots of columns. E.G. "Adviser" "First Name" "Investment Amount" "Commission Due" "Date Received" "File Check 1 Date" "File Check 1 by:" all that kind of stuff.
N.B. the worksheets do not have identical structures. So aggregation involves standardising all the tables into the same format as well as some other stuff.
Every month a report is put together manually, showing all the company's business, split out by adviser, type of business, provider (E.G. pension provider). This takes a lot of time and is very vulnerable to human error.
The project was to automate the process of creating this report. It works and is 100% accurate (so far as I can determine). It runs to about 2,000 lines across 3 Modules.
What I'm after with this question:
Using this project as an example of my current level of proficiency with best practices, I'm after specific suggestions on how it can be / could have been, structured / written to improve the following criteria:
Readability: Ability for somebody who is not me to come in blind, and (relatively) easily figure out how the whole thing works and fix some problem that's cropped up.
Robustness: Designing subs/functions to deal with variable cases. (E.G. I used to do a lot of using exact cell references, so if you added a column, the whole macro broke, in multiple places. Nowadays, I know better.)
Reusability: Designing subs/functions/the entire project so they can be easily re-purposed for future projects. (E.G. I rebuilt the sub for getting worksheet data into an array so it could be literally copy-pasted into any future project)
Scalability: Things like version control, Splitting subs between Modules, Controlling variable Scope, Adding more control layers, commenting, etc. Basically, if I had to do this project but it was 10 times bigger / more complicated, or involved larger structures than just a workbook, what should I do/change to make it easier to build, easier to debug, easier for me to design / implement, easier to change etc.
Any answer on any aspect of the above would be much appreciated. You can download the workbook /full code here.
Note: This post has most of the actual line-to-line code taken out while preserving the rest of the macro-structure because otherwise it would be WAY over the character limit for posts.
Module 1: "v0_2_M1_Main_Subs"
Option Explicit
Option Compare Text '/ Case Insensitive
Sub Generate_Adviser_Submissions_Report()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 12/August/2015
'/ Version: 0.2
'/
'/ Is Called By: None
'/
'/ Calls: Open_Workbooks
'/ Initialise_Worksheets
'/ Initialise_Collections_And_MetricHeadings
'/ Initialise_Providers_And_Advisers
'/ Insert_arrAscentric_LifeCo_Column
'/
'/ Sheet_Data_To_Array
'/ Filter_Sheet_Arrays
'/ Aggregate_Sheet_Data
'/
'/ Allocate_Business
'/
'/ Print_Adviser_Report
'/ Print_Provider_Report
'/
'/ Description: All Company Wealth Business is contained in the Subsheet. This macro produces adviser totals for business (assets and fees) in the previous year
'/ (month by month breakdown) by aggregating the subsheet into one giant table and then assigning each piece of business to an adviser, a Month and a business type.
'/ The report can then be easily configured for any desired outputs (E.G. by adviser, by provider, by type of business)
'/
'/ Change Log: | Author | Date | Description of Changes
'/ -----------------------------------------------------------------------------------------------------------------------------------
'/ |Zak armstrong | 12.08.2015 | Started v0.2 from scratch. Major difference: now aggregating all subsheet data first and
'/ | | | only then allocating each piece of business.
'/ | | |
'/ | | 14.08.2015 | "Finished" Writing Macro. Had succesful test run.
'/ | | |
'/ | | 17.08.2015 | Reviewed all code, replaced a lot of hard-coded references (e.g. specific position numbers) with
'/ | | | dynamically generated ones. Re-structured main allocation sub.
'/ | | |
'/ | | 18.08.2015 | Finished Writing Format_Adviser_Report, Format_Provider_Report, restructured macros from 1 module to 3.
'/ | | |
'/ | | 19.08.2015 | Double-Checked Code, Slight re-structuring/obfuscation before posting to Code Review (Stack Exchange)
'/ | | |
'/======================================================================================================================================================
'/ Variable Declaration
'/======================================================================================================================================================
Dim arrNewClient() As Variant '/ An array to hold all data on the "New Client Investment" Sheet
Dim arrExistingClient() As Variant '/ An array to hold all data on the "Existing Client Investment" Sheet
Dim arrGroupSchemes() As Variant '/ An array to hold all data on the "Group Schemes" Sheet
Dim arrOther() As Variant '/ An array to hold all data on the "Other" Sheet
Dim arrMcOngoing() As Variant '/ An array to hold all data on the "MC Ongoing" Sheet
Dim arrJhOngoing() As Variant '/ An array to hold all data on the "JH Ongoing" Sheet
Dim arrAegonQuilterArc() As Variant '/ An array to hold all data on the "AG-QU-ARC" Sheet
Dim arrAscentric() As Variant '/ An array to hold all data on the "Ascentric" Sheet
Dim I As Long '/ General counters
Dim J As Long '/
Dim K As Long '/
'/======================================================================================================================================================
'/==================================================
'/ Initialise save Filename
'/==================================================
strCurrentDate = "." & Day(Date) & "." & Month(Date) & "." & Year(Date)
strSavedReportFilename = "Adviser Submissions Report" & strCurrentDate & ".xlsm"
'/==================================================
'/ Check that the workbooks are open
'/==================================================
Call Open_Workbooks
'/==================================================
'/ Initialise Worksheet variables
'/==================================================
Call Initialise_Worksheets
'/==================================================
'/ Initialise Collections
'/==================================================
Call Initialise_Collections_And_MetricHeadings
'/==================================================
'/ Get all sheet data into arrays
'/==================================================
Call Sheet_Data_To_Array(wsNewClient, arrNewClient, "Adviser", 10, 10)
Call Sheet_Data_To_Array(wsExistingClient, arrExistingClient, "Adviser", 10, 10)
Call Sheet_Data_To_Array(wsGroupSchemes, arrGroupSchemes, "Adviser", 10, 10)
Call Sheet_Data_To_Array(wsOther, arrOther, "Adviser", 10, 10)
Call Sheet_Data_To_Array(wsMcOngoing, arrMcOngoing, "Adviser", 10, 10)
Call Sheet_Data_To_Array(wsJhOngoing, arrJhOngoing, "Adviser", 10, 10)
Call Sheet_Data_To_Array(wsAegonQuilterArc, arrAegonQuilterArc, "Adviser", 10, 10)
Call Sheet_Data_To_Array(wsAscentric, arrAscentric, "Account No", 10, 10)
Call Insert_arrAscentric_LifeCo_Column(arrAscentric)
'/==================================================
'/ Filter sheet data for desired columns
'/==================================================
Call Filter_Sheet_Arrays(arrNewClient)
Call Filter_Sheet_Arrays(arrExistingClient)
Call Filter_Sheet_Arrays(arrGroupSchemes)
Call Filter_Sheet_Arrays(arrOther)
Call Filter_Sheet_Arrays(arrMcOngoing)
Call Filter_Sheet_Arrays(arrJhOngoing)
Call Filter_Sheet_Arrays(arrAegonQuilterArc)
Call Filter_Sheet_Arrays(arrAscentric)
'/==================================================
'/ Aggregate Data
'/==================================================
Call Aggregate_Sheet_Data(arrNewClient, arrExistingClient, arrGroupSchemes, arrOther, arrMcOngoing, arrJhOngoing, arrAegonQuilterArc, arrAscentric)
Application.DisplayAlerts = False
wbSubsheet.Close
Application.DisplayAlerts = True
'/==================================================
'/ Populate arrAdvisers and arrProviders
'/==================================================
Call Initialise_Providers_And_Advisers
'/==================================================
'/ Allocate Business to Advisers, Providers, Business Type, Month. Calculate totals
'/==================================================
Call Allocate_Business
'/==================================================
'/ Print Reports
'/==================================================
Call Print_Adviser_Report
Call Print_Provider_Report
'Call Print_Product_Report
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Public Sub Sheet_Data_To_Array(ByRef wsCurrentsheet As Worksheet, ByRef arrCurrentArray() As Variant, ByVal strTopLeftCellIdentifier As String, _
ByVal lngRowsToSearch As Long, ByVal lngColumnsToSearch As Long)
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 12/August/2015
'/ Version: 1.0
'/
'/ Is Called By: Generate_Adviser_Submissions_Report
'/ Calls: -
'/
'/ Description: Generic "Get Data from worksheet into Array" subroutine. Slightly altered for this project.
'/ Important Info: Measures range of data based on the last used cells in the TopLeftCell's row and column. Case insensitive search.
'/
'/ Change Log: | Author | Date | Description of Changes
'/ -----------------------------------------------------------------------------------------------------------------------------------
'/ |Zak Armstrong | 12.08.2015 | Wrote Macro
'/ | | |
'/ | | |
'/======================================================================================================================================================
'/ Variable Declaration
'/======================================================================================================================================================
Dim I As Long '/ General counters
Dim J As Long '/
Dim K As Long '/
Dim lngFirstrow As Long '/ First row in the data range
Dim lngFirstColumn As Long '/ first column in the data range
Dim lngFinalRow As Long '/ Last row in the data range
Dim lngFinalColumn As Long '/ Last Column in the data range
Dim arrTempArray() As Variant '/ Temporarily holds the whole sheet
Dim rngWholeSheet As Range '/ Range to contain all the data
Dim bTopLeftCellFound As Boolean '/ Check to see if cell has been found
Dim lngLastPossibleCellRow As Long '/ The last possible row
Dim lngLastPossibleCellColumn As Long '/ The last possible column
'/======================================================================================================================================================
'/ Find TopLeftCell
'/ Define Range, put into Array
End Sub
Public Sub Filter_Sheet_Arrays(ByRef arrCurrentArray() As Variant)
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 12/August/2015
'/
'/ Is Called By: Generate_Adviser_Submissions_Report
'/ Calls: Array_Headings_Error_Handler
'/ Description: Takes Sheet arrays, finds the columns from the colAllHeadings, erases the array and recreates with just that data (and empty columns for the ones not found)
'/
'/ Change Log: | Author | Date | Description of Changes
'/ -----------------------------------------------------------------------------------------------------------------------------------
'/ |Zak armstrong | 12.08.2015 | Wrote Macro
'/ | | |
'/ | | |
'/======================================================================================================================================================
'/ Variable Declaration
'/======================================================================================================================================================
Dim I As Long '/ General counters
Dim J As Long '/
Dim K As Long '/
Dim lngFinalRow As Long '/ Last row in the data range
Dim lngFinalColumn As Long '/ Last Column in the data range
Dim arrTempArray() As Variant '/ Temporarily holds the filtered information
Dim arrHeadingsRow() As Variant '/ Holds the top (headings) row for application.match
Dim varMatchHolder As Variant '/ Holds the application.match result
Dim lngCurrentColumn As Long '/ The current column being copied
Dim strHeading As String '/ The current heading to search for
'/======================================================================================================================================================
'/ Create Array of Headings Row
'/ Check For Headings
'/ If not found
Call Array_Headings_Error_Handler(arrCurrentArray, strHeading)
End Sub
Public Sub Aggregate_Sheet_Data(ByRef arr1() As Variant, ByRef arr2() As Variant, ByRef arr3() As Variant, ByRef arr4() As Variant _
, ByRef arr5() As Variant, ByRef arr6() As Variant, ByRef arr7() As Variant, ByRef arr8() As Variant)
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 13/August/2015
'/
'/ Is Called By: Generate_Adviser_Report
'/
'/ Calls: None
'/
'/ Description: Aggregate the 8 filtered sheet arrays into one large array, then print to wsAggregatedData
'/
'/ Change Log: | Author | Date | Description of Changes
'/ -----------------------------------------------------------------------------------------------------------------------------------
'/ |Zak armstrong | 13.08.2015 | Wrote the Macro
'/ |
'/ |
'/======================================================================================================================================================
Dim rngTopLeftCell As Range '/ set the position for the table
Dim lngFirstrow As Long '/ Row of topleftcell
Dim lngFirstColumn As Long '/ column of topleftcell
Dim lngCurrentRow As Long '/ Current row of table
Dim lngFinalRow As Long '/ Boundaries of the table
Dim lngFinalColumn As Long '/
Dim I As Long
Dim J As Long
Dim K As Long
Dim rngTableRange As Range '/ for transferring array to sheet
Dim arrTransposedData() As Variant '/
'/======================================================================================================================================================
'/==================================================
'/ Set position of table
'/==================================================
'/==================================================
'/ Aggregate Data
'/==================================================
'/==================================================
'/ Transpose Data and print to worksheet
'/==================================================
'/==================================================
'/ Re-Populate arrAggregatedData with the transposed data
'/==================================================
End Sub
Public Sub Allocate_Business()
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 13/August/2015
'/
'/ Is Called By: Generate_Adviser_Submissions_Report
'/
'/ Calls: Allocation_error
'/
'/ Description: For each piece of business in the aggregated data, assign to an adviser, month, type of business and provider in arrAllocatedBusiness
'/
'/ Notes: I'm not particularly happy with the length, complexity or runtime of the main allocation procedure, but I've already re-designed it 3 times and this
'/ one at least seems to work and handles errors properly and runs in only a few seconds.
'/
'/ Change Log: | Author | Date | Description of Changes
'/ -----------------------------------------------------------------------------------------------------------------------------------
'/ |Zak armstrong | 13.08.2015 | Started writing Macro
'/ |zak Armstrong | 14.08.2015 | Finished Writing Macro
'/ |Zak Armstrong | 17.08.2015 | Reviewed Macro, re-structured main allocation part to be less complicated and more resilient.
'/======================================================================================================================================================
Dim lngCurrentRow As Long '/
Dim I As Long '/ General counters
Dim J As Long '/
Dim K As Long '/
Dim L As Long '/
Dim varAdviserPosition As Variant '/ Positions in the allocated business array
Dim varMetricPosition As Variant '/
Dim varDatePosition As Variant '/
Dim varProviderPosition As Variant '/
Dim varHeadingPosition As Variant '/ Position in arrAggregatedData
Dim varMonthPosition As Variant '/
Dim varMoneyReceivedPosition As Variant '/
Dim varDateSubmittedPosition As Variant '/
Dim varDateReceivedBankPosition As Variant '/
Dim varLifeCoColumn As Variant '/
Dim dtHolder As Date '/ Date Holder
Dim dblHolder As Double '/ Number holder
Dim strHolder As String '/ String holder
Dim varHolder As Variant '/ Variant Holder
Dim bTest1 As Boolean '/ General testing
Dim bTest2 As Boolean '/
Dim bTest3 As Boolean '/
Dim bTest4 As Boolean '/
Dim bTest5 As Boolean '/
Dim rngWholeSheet As Range '/ Range to contain all the data
Dim bTopLeftCellFound As Boolean '/ Check to see if cell has been found
Dim lngLastPossibleCellRow As Long '/ The last possible row
Dim lngLastPossibleCellColumn As Long '/ The last possible column
Dim strTopLeftCellIdentifier As String '/ The top left cell of the table
Dim lngRowsToSearch As Long
Dim lngColumnsToSearch As Long
Dim bMatchFound As Boolean '/
Dim bErrorFound As Boolean '/
Dim lngMonth As Long '/ The month the business corresponds to
Dim dblYearTotal As Double '/ The whole year totals for each variable
Dim lngCounter As Long '/
Dim lngFirstrow As Variant '/ First row in the data range
Dim lngFirstColumn As Variant '/ First column in the data range
Dim lngFinalRow As Variant '/ Last row in the data range
Dim lngFinalColumn As Variant '/ Last Column in the data range
'/ Reminder:
'/ Structure: arrAllocatedBusiness
'/
'/ (0) (1) (5)
'/ (0) | [DateStamp] | New Assets | Single Premiums | Monthly Premiums | Commission Generated | Commission Paid
'/ (1) | Adviser1 | ...
'/ | Adviser2 | ...
'/ | Adviser3 | ...
'/ | ... |
'/
'/ 3rd dimension: (0): [DateStamp] | [arrProviders] .....
'/ 4th dimension: (0): [DateStamp] | (1) Jan | (2) Feb | ... | (12) Dec | (13) Total
'/======================================================================================================================================================
'/==================================================
'/ Prepare arrAllocatedBusiness Headings
'/==================================================
'/==================================================
'/ Begin Main Loop
'/==================================================
'/==================================================
'/ Determine Adviser positions
'/==================================================
'/==================================================
'/ Determine Metric Position
'/==================================================
'/==================================================
'/ Determine Provider Position
'/==================================================
'/==================================================
'/ Determine Date Position / configuration
'/==================================================
'/ Perform tests
'/ bTest1
'/ bTest2
'/ bTest3
'/ bTest4
'/ bTest5
'/ test combination of results for error conditions
'/==================================================
'/ Allocate non-recurring business
'/==================================================
'/==================================================
'/ Allocate recurring business
'/==================================================
'/==================================================
'/ End Main Loop
'/==================================================
'/==================================================
'/ Calculate Totals
'/==================================================
End Sub
Public Sub Print_Adviser_Report()
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 14/August/2015
'/
'/ Is Called By: Generate_Adviser_Submissions_Report
'/
'/ Calls: None
'/
'/ Description: For each relevant dimension of arrAllocatedBusiness, calculates the relevant totals
'/
'/
'/ Change Log: | Author | Date | Description of Changes
'/ -----------------------------------------------------------------------------------------------------------------------------------
'/ |Zak armstrong | 14.08.2015 | Wrote Macro
'/ |
'/ |
'/======================================================================================================================================================
Dim I As Long '/ General counters
Dim J As Long '/
Dim K As Long '/
Dim L As Long '/
Dim varAdviserPosition As Variant '/ Positions in the array
Dim varMetricPosition As Variant '/
Dim varDatePosition As Variant '/
Dim varProviderPosition As Variant '/
Dim strAdviser As String '/ The Adviser parameter
Dim strMetric As String '/ The Metric parameter + The Adviser Parameter
Dim strProvider As String '/ The provider parameter + the Metric Parameter + The Adviser Parameter
Dim varDate As Variant '/ The Date parameter
Dim strHolder As String
Dim rngAnchorCell As Range '/ The anchor for a table of the report
Dim lngAnchorRow As Long '/
Dim lngAnchorColumn As Long '/
Dim lngCurrentRow As Long '/ Row counter
Dim lngRowsBetweenAdvisers As Long
Dim lngAdviserStartRow As Long
Dim bValueFound As Boolean
Dim bMetricFound As Boolean
Dim dblHolder As Double
Dim strFormula As String
'/ Formattning Variables
Dim lngFinalColumn As Long
Dim LngAdviserNameRow As Long
Dim lngInvestmentRow As Long
Dim lngMonthlyPremiumRow As Long
Dim lngSinglePremiumRow As Long
Dim lngCommissionDueRow As Long
Dim lngCommissionPaidRow As Long
Dim lngRecurringStartRow As Long
Dim lngRecurringEndRow As Long
Dim rngFormat As Range
'/ Reminder:
'/ Structure: arrAllocatedBusiness
'/
'/ (0) (1) (5)
'/ (0) | [DateStamp] | New Assets | Single Premiums | Monthly Premiums | Commission Generated | Commission Paid
'/ (1) | Adviser1 | ...
'/ | Adviser2 | ...
'/ | Adviser3 | ...
'/ | ... |
'/
'/ 3rd dimension: (0): [DateStamp] | [arrProviders] .....
'/ 4th dimension: (0): [DateStamp] | (1) Jan | (2) Feb | ... | (12) Dec | (13) Total
'/======================================================================================================================================================
'/ Initialise stuff
'/=================================================
'/ Adviser Loop
'/=================================================
'/=================================================
'/=================================================
'/ Metric Loop
'/=================================================
'/=================================================
'/=================================================
'/ Provider Loop
'/=================================================
'/=================================================
'/=================================================
'/ Date Loop
'/=================================================
'/=================================================
'/=================================================
'/ End Date Loop
'/=================================================
'/=================================================
'/=================================================
'/ End Provider Loop
'/=================================================
'/=================================================
'/=================================================
'/ End Metric Loop
'/=================================================
'/=================================================
'/=================================================
'/ End Adviser Loop
'/=================================================
'/=================================================
End Sub
Public Sub Print_Provider_Report()
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 14/August/2015
'/
'/ Is Called By: Generate_Adviser_Submissions_Report
'/
'/ Calls: None
'/
'/ Description: For each relevant dimension of arrAllocatedBusiness, calculates the relevant totals
'/
'/
'/ Change Log: | Author | Date | Description of Changes
'/ -----------------------------------------------------------------------------------------------------------------------------------
'/ |Zak armstrong | 14.08.2015 | Started writing Macro
'/ |
'/ |
'/======================================================================================================================================================
Dim I As Long '/ General counters
Dim J As Long '/
Dim K As Long '/
Dim L As Long '/
Dim varAdviserPosition As Variant '/ Positions in the array
Dim varMetricPosition As Variant '/
Dim varDatePosition As Variant '/
Dim varProviderPosition As Variant '/
Dim strAdviser As String '/ The Adviser parameter
Dim strMetric As String '/ The Metric parameter + The Adviser Parameter
Dim strProvider As String '/ The provider parameter + the Metric Parameter + The Adviser Parameter
Dim varDate As Variant '/ The Date parameter
Dim strHolder As String
Dim rngAnchorCell As Range '/ The anchor for a table of the report
Dim lngAnchorRow As Long '/
Dim lngAnchorColumn As Long '/
Dim lngCounter As Long '/
Dim lngCurrentRow As Long '/ Row counter
Dim lngRowsBetweenProviders As Long
Dim bValueFound As Boolean
Dim bAdviserFound As Boolean
Dim bMetricFound As Boolean
Dim bProviderFound As Boolean
Dim dblHolder As Double
Dim strFormula As String
'/ Formatting Variables
Dim lngFinalColumn As Long
Dim lngProviderNameRow As Long
Dim lngAdviserStartRow As Long
Dim lngAdviserEndRow As Long
Dim rngFormat As Range
'/ Reminder:
'/ Structure: arrAllocatedBusiness
'/
'/ (0) (1) (5)
'/ (0) | [DateStamp] | New Assets | Single Premiums | Monthly Premiums | Commission Generated | Commission Paid
'/ (1) | Adviser1 | ...
'/ | Adviser2 | ...
'/ | Adviser3 | ...
'/ | ... |
'/
'/ 3rd dimension: (0): [DateStamp] | [arrProviders] .....
'/ 4th dimension: (0): [DateStamp] | (1) Jan | (2) Feb | ... | (12) Dec | (13) Total
'/======================================================================================================================================================
'/ Similar to Adviser Report, but re-arranged somewhat
'/=================================================
'/ Provider Loop
'/=================================================
'/=================================================
'/=================================================
'/ Adviser Loop
'/=================================================
'/=================================================
'/=================================================
'/ Date Loop
'/=================================================
'/=================================================
'/=================================================
'/ End Date Loop
'/=================================================
'/=================================================
'/=================================================
'/ End Adviser loop
'/=================================================
'/=================================================
'/=================================================
'/ End Provider Loop
'/=================================================
'/=================================================
End Sub
Module 2: "v_2_M2_Auxilary_Subs"
Option Explicit
Option Compare Text
Public Sub Allocation_Error(lngCurrentRow As Long)
'/ Error Message / Details
End Sub
Public Sub Array_Position_Error()
'/ Error Message / Details
End Sub
Public Sub Insert_arrAscentric_LifeCo_Column(ByRef arrAscentric() As Variant)
'/ Insert a column into arrascentric with "Life Co" details
End Sub
Public Function Array_Position(ByVal varSearch As Variant, ByRef arrSearchArray() As Variant, ByVal lngNumberOfDimensions As Long, ByVal lngDimensionToSearch As Long, _
Optional ByVal lngFirstDimensionLbound As Variant, Optional ByVal lngFirstDimensionUbound As Variant, _
Optional ByVal lngSecondDimensionLbound As Variant, Optional ByVal lngSecondDimensionUbound As Variant, _
Optional ByVal lngThirdDimensionLbound As Variant, Optional ByVal lngThirdDimensionUbound As Variant, _
Optional ByVal lngFourthDimensionLbound As Variant, Optional ByVal lngFourthDimensionUbound As Variant, _
Optional ByVal lngFifthDimensionLbound As Variant, Optional ByVal lngFifthDimensionUbound As Variant)
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 14/August/2015
'/
'/ Is Called By: Allocate_Business_To_Adviser
'/
'/ Calls: None
'/
'/ Description: General "Find position of string in dimension of Array" Sub
'/
'/ N.B. only accepts arrays up to 5 dimensions
'/
'/ Returns null if no match found
'/======================================================================================================================================================
'/======================================================================================================================================================
End Function
Public Sub Open_Workbooks()
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 17/August/2015
'/
'/ Is Called By: Generate_Adviser_Submissions_Report
'/
'/ Calls: None
'/
'/ Description: Checks that the workbooks are open. If not, tries to open them and checks again.
'/======================================================================================================================================================
End Sub
Module 3: v0_2_M3_Manual_Settings_or_Subs
Option Explicit
Option Compare Text
'/ Workbooks
Public wbSubsheet As Workbook '/ Contains all Company Wealth submitted Business
Public wbAdviserReport As Workbook '/ Will Contain an aggregation of the subsheet and a submission report (by month) for each adviser
'/ Adviser Report worksheets
Public wsAggregatedData As Worksheet '/ Will contain the aggregated subsheet data
Public wsAdviserReport As Worksheet '/ Will contain the submissions report, reported by Adviser
Public wsProviderReport As Worksheet '/ Will contain the submissions report, reported by Provider
Public wsProductReport As Worksheet '/ Will contain the submissions report, reportrd by Type of Business
'/ Subsheet Worksheets
Public wsNewClient As Worksheet '/ 'New Client' Investments of Assets
Public wsExistingClient As Worksheet '/ 'Existing Client' Investments of assets
Public wsGroupSchemes As Worksheet '/ 'e.g. corporate pension schemes
Public wsOther As Worksheet '/ Misc. bits and pieces
Public wsMcOngoing As Worksheet '/ M's recurring product commissions e.g. insurance policies
Public wsJhOngoing As Worksheet '/ J's recurring product commissions e.g. insurance policies
Public wsAegonQuilterArc As Worksheet '/ Recurring fees from accounts with Aegon, Quilter and ARC
Public wsAscentric As Worksheet '/ Recurring fees from accounts on Asccentric
'/ Data Arrays
Public arrAggregatedData() As Variant '/ An Array to hold the data from all worksheets
Public arrAllocatedBusiness() As Variant '/ An array to hold all the Business, "all"ocated by adviser and by month
'/ Structure: arrAllocatedBusiness
'/
'/ (0) (1) (6)
'/ (0) | [DateStamp] | New Assets | Single Premiums | Monthly Premiums | Commission Generated | Commission Paid | Recurring
'/ (1) | Adviser1 | ...
'/ | Adviser2 | ...
'/ | Adviser3 | ...
'/ | ... |
'/
'/ 3rd dimension: (0): [DateStamp] | [arrProviders] .....
'/ 4th dimension: (0): [DateStamp] | (1) Jan | (2) Feb | ... | (12) Dec | (13) Total
Public arrProviders() As Variant '/ will be populated with all providers found in the subsheet
Public arrAdvisers() As Variant '/ All the advisers found in the subsheet
'/ Collections of names
Public colAllHeadings As Collection '/ All desired Column Headings from the subsheet
Public colWorksheetNames As Collection '/ The names of all the worksheets
Public colMetrics As Collection '/ Metrics in the final report
'/ Constants, and variables that should be constants
Public strCurrentDate As String '/ The current Date for datestamping the saved report
Public strSavedReportFilename As String '/ The filename to save the report as
Public Const strAdviserReportFilePath As String = "S:\Company Admin Docs\Adviser Submission Reports\" '/ The path of the folder containing the Adviser Report
Public Const strSavedReportsFilePath As String = "S:\Company Admin Docs\Adviser Submission Reports\Saved Reports\" '/ The path of the folder containing previous reports
Public Const strSubsheetFilePath As String = "S:\Company Admin Docs\Subsheet and Commission statements\" '/ The path of the folder containing the Subsheet
Public Const strAdviserReportFilename As String = "Adviser Submissions Report.xlsm" '/ The filename of the Adviser Submissions Report
Public Const strSubsheetFilename As String = "Company Subsheet 2015.xlsm" '/ The filename of the Subsheet
Public Const lngFinalCellRow As Long = 1048576 '/ The last possible row
Public Const lngFinalCellColumn As Long = 16384 '/ The last possible column
Public Sub Initialise_Worksheets()
'/======================================================================================================================================================
'/ Is called by: Generate_Adviser_Submissions_Report
'/ Calls: -
'/ Date: 10.08.2015
'/======================================================================================================================================================
wbAdviserReport.Activate
Set wsAggregatedData = wbAdviserReport.Worksheets("Aggregated Subsheet Data")
Set wsAdviserReport = wbAdviserReport.Worksheets("Adviser Submissions Report")
Set wsProviderReport = wbAdviserReport.Worksheets("Provider Submissions Report")
Set wsProductReport = wbAdviserReport.Worksheets("Product Submissions Report")
wbSubsheet.Activate
Set wsNewClient = wbSubsheet.Worksheets("New Client Investment")
Set wsExistingClient = wbSubsheet.Worksheets("Existing Client Investment")
Set wsGroupSchemes = wbSubsheet.Worksheets("Group Schemes")
Set wsOther = wbSubsheet.Worksheets("Other")
Set wsMcOngoing = wbSubsheet.Worksheets("MC Ongoing")
Set wsJhOngoing = wbSubsheet.Worksheets("JH Ongoing")
Set wsAegonQuilterArc = wbSubsheet.Worksheets("AG-QU-ARC")
Set wsAscentric = wbSubsheet.Worksheets("Ascentric")
End Sub
Public Sub Initialise_Collections_And_MetricHeadings()
'/======================================================================================================================================================
'/ Is called by: Generate_Adviser_Submissions_Report
'/ Calls: -
'/ Date: 10.08.2015
'/======================================================================================================================================================
Dim I As Long
Set colWorksheetNames = New Collection
'/ List of Strings to add
Set colAllHeadings = New Collection
'/ N.B. this will be the order of headings in the aggregated sheet
'/ List of Strings to add
For I = 1 To 12
colAllHeadings.Add (DateValue("01/" & Right("0" & I, 2) & "/" & Year(Date)))
Next I
Set colMetrics = New Collection
'/ List of Strings to add
End Sub
Public Sub Array_Headings_Error_Handler(ByRef arrCurrentArray() As Variant, ByVal strHeading As String)
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 13/August/2015
'/
'/ Is Called By: Filter_Sheet_Arrays
'/
'/ Calls: None
'/
'/ Description: Handle instances where a column heading can't be found. Reference against sheet-specific lists to see if the column should be there or not.
'/======================================================================================================================================================
Dim bErrorFound As Boolean '/ General error indicator
Dim colMissingSheetHeadings As Collection '/ For each sheet, contains the headings that shouldn't be there
Dim I As Long '/ General Counters
Dim J As Long '/
Dim K As Long '/
'/======================================================================================================================================================
bErrorFound = True
Set colMissingSheetHeadings = New Collection
Select Case arrCurrentArray(0, 0) '/ Contains the name of the worksheet the data was taken from
Case Is = wsNewClient.Name
'/ List of columns not in the worksheet
For I = 1 To 12
colMissingSheetHeadings.Add (DateValue("01/" & Right("0" & I, 2) & "/" & Year(Date)))
Next I
For I = 1 To colMissingSheetHeadings.Count
If strHeading = colMissingSheetHeadings(I) Then bErrorFound = False
Next I
'/ Same For each worksheet Case
Case Else
bErrorFound = True
End Select
If bErrorFound = True _
Then
MsgBox ("Couldn't find Column Heading: " & arrCurrentArray(0, 0) & ": " & strHeading)
Debug.Print "Couldn't find Column Heading: " & arrCurrentArray(0, 0) & ": " & strHeading
Exit Sub
End If
End Sub
Public Sub Initialise_Providers_And_Advisers()
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 14/August/2015
'/
'/ Is Called By: Generate_Adivser_Report
'/
'/ Calls: None
'/
'/ Description: Searches aggregated data, generates a list of all unique "Life Co" Provider Names and all Unique "Adviser" Names
'/======================================================================================================================================================
Dim lngCurrentRow As Long '/ Current row of table
Dim lngCurrentColumn As Long '/ The current column being copied
Dim lngFinalRow As Long '/ Boundaries of the table
Dim lngFinalColumn As Long '/
Dim I As Long
Dim J As Long
Dim K As Long
Dim arrHeadingsRow() As Variant '/ Holds the top (headings) row for application.match
Dim varMatchHolder As Variant '/ Holds the application.match result
Dim strHeading As String '/ The current heading to search for
Dim strHolder As String '/ The provider name to search for
Dim bMatchFound As Boolean '/ Is the provider name already in the list?
Dim lngNameCounter As Long '/
'/======================================================================================================================================================
lngFinalRow = UBound(arrAggregatedData, 1)
lngFinalColumn = UBound(arrAggregatedData, 2)
'/==================================================
'/ Determine "Life Co" column
'/==================================================
lngCurrentColumn = Array_Position("Life Co", arrAggregatedData, 2, 2, 1, 1, "all", "all")
If IsNull(lngCurrentColumn) _
Then
MsgBox "Couldn't find ""Life Co"" In arrAggregateddata"
Debug.Print "Couldn't find ""Life Co"" In arrAggregateddata"
End
End If
'/==================================================
'/ Fill list of unique provider names
'/==================================================
lngNameCounter = 0
ReDim Preserve arrProviders(1 To 1)
For lngCurrentRow = 2 To lngFinalRow
bMatchFound = False
strHolder = arrAggregatedData(lngCurrentRow, lngCurrentColumn)
If strHolder = "" _
Then
strHolder = "No Provider"
arrAggregatedData(lngCurrentRow, lngCurrentColumn) = "No Provider"
End If
For I = 1 To UBound(arrProviders)
If strHolder = arrProviders(I) Then bMatchFound = True
Next I
If bMatchFound = False _
Then
lngNameCounter = lngNameCounter + 1
ReDim Preserve arrProviders(1 To lngNameCounter)
arrProviders(lngNameCounter) = strHolder
End If
Next lngCurrentRow
ReDim Preserve arrProviders(1 To lngNameCounter + 1)
arrProviders(lngNameCounter + 1) = "Ascentric"
'/==================================================
'/ Determine "Adviser" column
'/==================================================
lngCurrentColumn = Array_Position("Adviser", arrAggregatedData, 2, 2, 1, 1, "all", "all")
If IsNull(lngCurrentColumn) _
Then
MsgBox "Couldn't find ""Adviser"" In arrAggregateddata"
Debug.Print "Couldn't find ""Adviser"" In arrAggregateddata"
End
End If
'/==================================================
'/ Deal with variations on names
'/==================================================
'' Replaces Adviser First Names with Full Names
'/==================================================
'/ Fill list of unique Adviser names
'/==================================================
lngNameCounter = 0
ReDim Preserve arrAdvisers(1 To 1)
For lngCurrentRow = 2 To lngFinalRow
bMatchFound = False
strHolder = arrAggregatedData(lngCurrentRow, lngCurrentColumn)
For I = 1 To UBound(arrAdvisers)
If strHolder = arrAdvisers(I) Then bMatchFound = True
Next I
If bMatchFound = False _
Then
lngNameCounter = lngNameCounter + 1
ReDim Preserve arrAdvisers(1 To lngNameCounter)
arrAdvisers(lngNameCounter) = strHolder
End If
Next lngCurrentRow
End Sub
SubSheetwhich you can use for pivot tables. \$\endgroup\$