First off, this is version 2 of a previous question about the same macro: Previous Version. Thank you to Raystafarian, RubberDuck and everyone in chat who helped me make it better.
The Macro accesses a workbook containing 8 worksheets each with similarly structured but not identical tables of data (submitted business for my company). It then filters this data for desired columns and aggregates it into a separate workbook.
As before, I'd like advice/feedback on improving the following:
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 and/or to reliably fail when given unintended arguments.
Reusability: Designing subs/functions/the entire project so they can be easily re-purposed for future projects.
What Changed: The order in which the Macro does things is roughly the same, but almost everything else was entirely re-written / re-factored from scratch.
Bugs Found: The public sub ErrorMessage calls RestoreApplicationSettings but doesn't have the variables it's trying to pass as arguments. These 3 arguments varScreenUpdating, varEnableEvents, varCalculation have been made Public variables and moved to the Public Variable Module.
Module 1: "M1_Public_Variables_Constants"
Option Explicit
'/ Workbooks
Public WbSubsheet As Workbook '/ Contains all Lumin 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 and/or Auto Enrolment
Public WsOther As Worksheet '/ Misc. bits and pieces
Public WsMcOngoing As Worksheet '/ Martin's recurring product commissions e.g. insurance policies
Public WsJhOngoing As Worksheet '/ Jon'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 ArrAggregatedArrays As Variant '/ Holds all the sheet-Data Arrays
Public ArrAggregatedData As Variant '/ The data from all worksheets
Public ArrProviders As Variant '/ 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 ColMetrics As Collection '/ Metrics in the final report
'/ Constants, and variables that are only set once
Public StrCurrentDate As String '/ The current Date for datestamping the saved report
Public StrSavedReportFilename As String '/ The filename to save the report as
Public varScreenUpdating As Variant '/ Application Settings
Public varEnableEvents As Variant '/
Public varCalculation As Variant '/
Public Const StrAdviserReportFilePath As String = "S:\Lumin Admin Docs\Adviser Submission Reports\" '/ The path of the folder containing the Adviser Report
Public Const StrSavedReportsFilePath As String = "S:\Lumin Admin Docs\Adviser Submission Reports\Saved Reports\" '/ The path of the folder containing previous reports
Public Const StrSubsheetFilePath As String = "S:\Lumin Admin Docs\Subsheet and Commission statements\" '/ The path of the folder containing the Subsheet
Public Const StrAdviserReportFilename As String = "Adviser Submissions Report - v0.3.xlsm" '/ The filename of the Adviser Submissions Report
Public Const StrSubsheetFilename As String = "Lumin Subsheet 2015.xlsm" '/ The filename of the Subsheet
Public Const LngFinalCellRow As Long = 1048576
Public Const LngFinalCellColumn As Long = 16384
Module 2: "M2_Main_Subs" - Core Over-arching Subs
Option Explicit
Option Compare Text
Public Sub GenerateAdviserSubmissionReports()
Call StoreApplicationSettings(varScreenUpdating, varEnableEvents, varCalculation)
Call DisableApplicationSettings
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 21/August/2015
'/ Version: 0.3
'/
'/ Description: All Lumin 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)
'/======================================================================================================================================================
Dim arrNewClient As Variant '/ all data on the "New Client Investment" Sheet
arrNewClient = Array()
Dim arrExistingClient As Variant '/ all data on the "Existing Client Investment" Sheet
arrExistingClient = Array()
Dim arrGroupSchemes As Variant '/ all data on the "Group Schemes" Sheet
arrGroupSchemes = Array()
Dim arrOther As Variant '/ all data on the "Other" Sheet
arrOther = Array()
Dim arrMcOngoing As Variant '/ all data on the "MC Ongoing" Sheet
arrMcOngoing = Array()
Dim arrJhOngoing As Variant '/ all data on the "JH Ongoing" Sheet
arrJhOngoing = Array()
Dim arrAegonQuilterArc As Variant '/ all data on the "AG-QU-ARC" Sheet
arrAegonQuilterArc = Array()
Dim arrAscentric As Variant '/ all data on the "Ascentric" Sheet
arrAscentric = Array()
Dim i As Long '/ General counters
Dim j As Long '/
Dim k As Long '/
'/======================================================================================================================================================
Call InitialiseStuff
'/==================================================
'/ Get all sheet data into arrays
'/==================================================
Dim strTopLeftCellIdentifier As String
strTopLeftCellIdentifier = "Adviser"
Call PutSheetDataInArray(WbSubsheet, WsNewClient, arrNewClient, strTopLeftCellIdentifier)
Call PutSheetDataInArray(WbSubsheet, WsExistingClient, arrExistingClient, strTopLeftCellIdentifier)
Call PutSheetDataInArray(WbSubsheet, WsGroupSchemes, arrGroupSchemes, strTopLeftCellIdentifier)
Call PutSheetDataInArray(WbSubsheet, WsOther, arrOther, strTopLeftCellIdentifier)
Call PutSheetDataInArray(WbSubsheet, WsMcOngoing, arrMcOngoing, strTopLeftCellIdentifier)
Call PutSheetDataInArray(WbSubsheet, WsJhOngoing, arrJhOngoing, strTopLeftCellIdentifier)
Call PutSheetDataInArray(WbSubsheet, WsAegonQuilterArc, arrAegonQuilterArc, strTopLeftCellIdentifier)
strTopLeftCellIdentifier = "Account No"
Call PutSheetDataInArray(WbSubsheet, WsAscentric, arrAscentric, strTopLeftCellIdentifier)
Call InsertAscentricLifeCoColumn(arrAscentric)
ReDim ArrAggregatedArrays(1 To 8)
ArrAggregatedArrays(1) = arrNewClient
ArrAggregatedArrays(2) = arrExistingClient
ArrAggregatedArrays(3) = arrGroupSchemes
ArrAggregatedArrays(4) = arrOther
ArrAggregatedArrays(5) = arrMcOngoing
ArrAggregatedArrays(6) = arrJhOngoing
ArrAggregatedArrays(7) = arrAegonQuilterArc
ArrAggregatedArrays(8) = arrAscentric
'/==================================================
'/ Filter sheet data for desired columns
'/==================================================
For i = LBound(ArrAggregatedArrays) To UBound(ArrAggregatedArrays)
Call FilterSheetArrayForColumns(ArrAggregatedArrays(i))
Next i
'/==================================================
'/ Aggregate Data
'/==================================================
Call AggregateSheetData
Application.DisplayAlerts = False
WbSubsheet.Close
Application.DisplayAlerts = True
'/==================================================
'/ Print Data
'/==================================================
Dim rngStartCell As Range
Set rngStartCell = WsAggregatedData.Cells(1, 1)
Call Print2dArrayToSheet(WbAdviserReport, WsAggregatedData, ArrAggregatedData, rngStartCell)
Call RestoreApplicationSettings(varScreenUpdating, varEnableEvents, varCalculation)
End Sub
Public Sub FilterSheetArrayForColumns(ByRef arrCurrentArray As Variant)
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 12/August/2015
'/
'/ Description: Takes Sheet arrays, finds the columns from the colAllHeadings, recreates the array with just that data (and empty columns for the ones not found)
'/======================================================================================================================================================
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngFinalRow As Long
Dim lngFinalColumn As Long
Dim arrTempArray As Variant '/ Temporarily holds the filtered information
arrTempArray = Array()
Dim arrHeadingsRow As Variant '/ Holds the top (headings) row for application.match
arrHeadingsRow = Array()
Dim varColumnPosition As Variant '/ Holds the position of the relevant column
Dim strHeading As String '/ The current heading to search for
'/======================================================================================================================================================
Call AssignArrayBounds(arrCurrentArray:=arrCurrentArray, UB1:=lngFinalRow, UB2:=lngFinalColumn)
'/==================================================
'/ Recreate Headings Row
'/==================================================
ReDim arrHeadingsRow(1 To lngFinalColumn)
For i = 1 To lngFinalColumn
arrHeadingsRow(i) = arrCurrentArray(1, i)
Next i
'/==================================================
'/ Find Columns, put in array
'/==================================================
ReDim arrTempArray(0 To lngFinalRow, 0 To ColAllHeadings.Count)
arrTempArray(0, 0) = arrCurrentArray(0, 0)
Dim lngDestinationColumn As Long
Dim lngSourceColumn As Long
For i = 1 To ColAllHeadings.Count
strHeading = ColAllHeadings(i)
varColumnPosition = Application.Match(strHeading, arrHeadingsRow, 0)
If IsError(varColumnPosition) _
Then
Call MissingDataHeadingsHandler(arrCurrentArray, strHeading)
Else
lngDestinationColumn = i
lngSourceColumn = varColumnPosition
Call CopyColumn2d(arrCurrentArray, arrTempArray, lngSourceColumn, lngDestinationColumn)
End If
Next i
Call CopyArrayContents2d(arrTempArray, arrCurrentArray)
End Sub
Public Sub AggregateSheetData()
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 13/August/2015
'/
'/ Description: For Each array, add the data to arrAggregatedData
'/======================================================================================================================================================
Dim rngTopLeftCell As Range
Dim lngFirstRow As Long
Dim lngFirstColumn As Long
Dim lngCurrentRow As Long
Dim lngFinalRow As Long
Dim lngFinalColumn As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim rngTableRange As Range
Dim arrTransposedData() As Variant
Dim strHolder As String
Dim LB1 As Long
Dim UB1 As Long
Dim LB2 As Long
Dim UB2 As Long
'/======================================================================================================================================================
'/==================================================
'/ Aggregate Data
'/==================================================
lngCurrentRow = 1
ReDim ArrAggregatedData(1 To ColAllHeadings.Count, 1 To 1)
For i = 1 To ColAllHeadings.Count
ArrAggregatedData(i, 1) = ColAllHeadings(i)
Next i
For i = LBound(ArrAggregatedArrays) To UBound(ArrAggregatedArrays)
Call AssignArrayBounds(ArrAggregatedArrays(i), LB1, UB1, LB2, UB2)
For j = LB1 + 2 To UB1
lngCurrentRow = lngCurrentRow + 1
ReDim Preserve ArrAggregatedData(1 To ColAllHeadings.Count, 1 To lngCurrentRow)
For k = LB2 + 1 To UB2
ArrAggregatedData(k, lngCurrentRow) = ArrAggregatedArrays(i)(j, k)
Next k
Next j
Next i
'/==================================================
'/ Transpose Data
'/==================================================
Call Transpose2dArray(ArrAggregatedData)
'/==================================================
'/ Print to sheet
'/==================================================
Call Print2dArrayToSheet(wbTarget, wsTarget, arrData, rngStartCell)
End Sub
Module 3: "M3_Auxilary_Subs" - Methods that are uniquely for this macro
Option Explicit
Option Compare Text
Public Sub InitialiseStuff()
'/ initialise public arrays
ArrAggregatedData = Array()
ArrAggregatedArrays = Array()
ArrProviders = Array()
ArrAdvisers = Array()
Call GetWorkbook(StrAdviserReportFilename, StrAdviserReportFilePath)
Set WbAdviserReport = Workbooks(StrAdviserReportFilename)
Call GetWorkbook(StrSubsheetFilename, StrSubsheetFilePath)
Set WbSubsheet = Workbooks(StrSubsheetFilename)
Call AssignWorksheets
Call InitialiseCollections
End Sub
Public Sub InsertAscentricLifeCoColumn(ByRef arrAscentric As Variant)
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 17/August/2015
'/
'/ Description: Inserts a column in the ascentric data array called "Life Co" and filled with "Ascentric" for easy identification later
'/======================================================================================================================================================
Dim i As Long
Dim j As Long
Dim k As Long
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
'/======================================================================================================================================================
Call AssignArrayBounds(arrAscentric, LB1, UB1, LB2, UB2)
ReDim Preserve arrAscentric(LB1 To UB1, LB2 To UB2 + 1)
arrAscentric(LB1 + 1, UB2 + 1) = "Life Co"
For i = LB1 + 2 To UB1
arrAscentric(i, UB2 + 1) = "Ascentric"
Next i
End Sub
Public Sub MissingDataHeadingsHandler(ByRef arrCurrentArray As Variant, ByVal strHeading As String)
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 13/August/2015
'/
'/ 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
Dim colMissingSheetHeadings As Collection '/ For each sheet, contains the headings that shouldn't be there
Dim strException As String '/ holds string items from colMissingSheetHeadings
Dim strErrorMessage As String
Dim i As Long
Dim j As Long
Dim k As Long
'/======================================================================================================================================================
strErrorMessage = "Couldn't find Column Heading: " & arrCurrentArray(0, 0) & ": " & strHeading
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
Call InitialiseNewClientHeadingsExceptions(colMissingSheetHeadings)
Case Is = WsExistingClient.Name
Call InitialiseExistingClientHeadingsExceptions(colMissingSheetHeadings)
Case Is = WsGroupSchemes.Name
Call InitialiseGroupSchemesHeadingsExceptions(colMissingSheetHeadings)
Case Is = WsOther.Name
Call InitialiseOtherHeadingsExceptions(colMissingSheetHeadings)
Case Is = WsMcOngoing.Name
Call InitialiseMcOngoingHeadingsExceptions(colMissingSheetHeadings)
Case Is = WsJhOngoing.Name
Call InitialiseJhOngoingHeadingsExceptions(colMissingSheetHeadings)
Case Is = WsAegonQuilterArc.Name
Call InitialiseAegonQuilterArcHeadingsExceptions(colMissingSheetHeadings)
Case Is = WsAscentric.Name
Call InitialiseAscentricHeadingsExceptions(colMissingSheetHeadings)
Case Else
Call ErrorMessage(strErrorMessage)
End Select
For i = 1 To colMissingSheetHeadings.Count
strException = colMissingSheetHeadings(i)
If strHeading = strException Then bErrorFound = False
Next i
If bErrorFound = True Then Call ErrorMessage(strErrorMessage)
End Sub
Module 4: "M4_Manual_Settings" - Subs that assign manually-set values
Option Explicit
Option Compare Text
Public Sub AssignWorksheets()
'/======================================================================================================================================================
'/ Date: 21.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 InitialiseCollections()
'/======================================================================================================================================================
'/ Date: 21.08.2015
'/======================================================================================================================================================
Dim i As Long
'/======================================================================================================================================================
Set ColAllHeadings = New Collection
'/ N.B. this will be the order of headings in the aggregated sheet
ColAllHeadings.Add ("Adviser")
ColAllHeadings.Add ("First Name")
ColAllHeadings.Add ("Last Name")
ColAllHeadings.Add ("Account Name")
ColAllHeadings.Add ("Life Co")
ColAllHeadings.Add ("Date Submitted")
ColAllHeadings.Add ("Description")
ColAllHeadings.Add ("Investment Amount")
ColAllHeadings.Add ("Money Received")
ColAllHeadings.Add ("Total Monthly Premium")
ColAllHeadings.Add ("Single Premium")
ColAllHeadings.Add ("Commission Due")
ColAllHeadings.Add ("Comm Paid - Checked To Bank")
ColAllHeadings.Add ("Date Received - Bank")
For i = 1 To 12
ColAllHeadings.Add (DateValue("01/" & Right("0" & i, 2) & "/" & Year(Date)))
Next i
Set ColMetrics = New Collection
ColMetrics.Add ("Investment Amount")
ColMetrics.Add ("Single Premium")
ColMetrics.Add ("Total Monthly Premium")
ColMetrics.Add ("Commission Due")
ColMetrics.Add ("Comm Paid - Checked To Bank")
ColMetrics.Add ("Recurring")
End Sub
Public Sub InitialiseNewClientHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)
Dim i As Long
colMissingSheetHeadings.Add ("Total Monthly Premium")
colMissingSheetHeadings.Add ("Single Premium")
colMissingSheetHeadings.Add ("Account Name")
colMissingSheetHeadings.Add ("Life Co")
For i = 1 To 12
colMissingSheetHeadings.Add (DateValue("01/" & Right("0" & i, 2) & "/" & Year(Date)))
Next i
End Sub
Public Sub InitialiseExistingClientHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)
'/ Different List of names
End Sub
Public Sub InitialiseGroupSchemesHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)
'/ Different List of names
End Sub
Public Sub InitialiseOtherHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)
'/ Different List of names
End Sub
Public Sub InitialiseMcOngoingHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)
'/ Different List of names
End Sub
Public Sub InitialiseJhOngoingHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)
'/ Different List of names
End Sub
Public Sub InitialiseAegonQuilterArcHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)
'/ Different List of names
End Sub
Public Sub InitialiseAscentricHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)
'/ Different List of names
End Sub
Module 5: "M5_Standard_Subs_Functions" - The ever-expanding module of Methods
Option Explicit
Option Compare Text
Public Function IsWorkbookOpen(ByVal strTargetName As String) As Boolean
On Error Resume Next
Workbooks(strTargetName).Activate
If ActiveWorkbook.Name <> strTargetName _
Then
IsWorkbookOpen = False
Else
IsWorkbookOpen = True
End If
On Error GoTo 0
End Function
Public Sub PutSheetDataInArray(ByRef wbCurrentWorkbook As Workbook, ByRef wsCurrentWorksheet As Worksheet, ByRef arrCurrentArray As Variant, ByVal strTopLeftCellIdentifier As String, _
Optional ByVal lngStartRow As Long = 1, Optional ByVal lngEndRow As Long = 10, _
Optional ByVal lngStartColumn As Long = 1, Optional ByVal lngEndColumn As Long = 10)
'/======================================================================================================================================================
'/ Author: Zak Armstrong
'/ Email: [email protected]
'/ Date: 21/August/2015
'/======================================================================================================================================================
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngFirstRow As Long
Dim lngFirstColumn As Long
Dim lngFinalRow As Long
Dim lngFinalColumn As Long
Dim rngTopLeftCell As Range
Dim rngSearchRange As Range
Dim strErrorMessage As String
'/======================================================================================================================================================
'/==================================================
'/ Open Worksheet
'/==================================================
wbCurrentWorkbook.Activate
wsCurrentWorksheet.Activate
wsCurrentWorksheet.Cells.EntireRow.Hidden = False
'/==================================================
'/ Find TopLeftCell
'/==================================================
If IsMissing(lngEndRow) Then lngEndRow = wsCurrentWorksheet.Rows.Count
If IsMissing(lngEndColumn) Then lngEndColumn = wsCurrentWorksheet.Columns.Count
Set rngSearchRange = wsCurrentWorksheet.Range(Cells(lngStartRow, lngStartColumn), Cells(lngEndRow, lngEndColumn))
Set rngTopLeftCell = rngSearchRange.Find(strTopLeftCellIdentifier, LookIn:=xlValues)
If rngTopLeftCell Is Nothing _
Then
strErrorMessage = "Couldn't find cell """ & strTopLeftCellIdentifier & """ in " & wsCurrentWorksheet.Name
Call ErrorMessage(strErrorMessage)
End If
'/==================================================
'/ Determine range of data, pass to array
'/==================================================
lngFirstRow = rngTopLeftCell.Row
lngFirstColumn = rngTopLeftCell.Column
lngFinalRow = Cells(LngFinalCellRow, lngFirstColumn).End(xlUp).Row
lngFinalColumn = Cells(lngFirstRow, LngFinalCellColumn).End(xlToLeft).Column
ReDim arrCurrentArray(0 To lngFinalRow - lngFirstRow + 1, 0 To lngFinalColumn - lngFirstColumn + 1)
arrCurrentArray(0, 0) = wsCurrentWorksheet.Name
For i = lngFirstRow To lngFinalRow
For j = lngFirstColumn To lngFinalColumn
arrCurrentArray(i - lngFirstRow + 1, j - lngFirstColumn + 1) = wsCurrentWorksheet.Cells(i, j)
Next j
Next i
End Sub
Public Sub CopyArrayContents5d(ByRef arrSource As Variant, ByRef arrDestination As Variant)
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
Dim LB3 As Long, UB3 As Long
Dim LB4 As Long, UB4 As Long
Dim LB5 As Long, UB5 As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long
Call AssignArrayBounds(arrSource, LB1, UB1, LB2, UB2, LB3, UB3, LB4, UB4, LB5, UB5)
Erase arrDestination
ReDim arrDestination(LB1 To UB1, LB2 To UB2, LB3 To UB3, LB4 To UB4, LB5 To UB5)
For i = LB1 To UB1
For j = LB2 To UB2
For k = LB3 To UB3
For l = LB4 To UB4
For m = LB5 To UB5
arrDestination(i, j, k, l, m) = arrSource(i, j, k, l, m)
Next m
Next l
Next k
Next j
Next i
End Sub
Public Sub CopyArrayContents4d(ByRef arrSource As Variant, ByRef arrDestination As Variant)
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
Dim LB3 As Long, UB3 As Long
Dim LB4 As Long, UB4 As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Call AssignArrayBounds(arrSource, LB1, UB1, LB2, UB2, LB3, UB3, LB4, UB4)
Erase arrDestination
ReDim arrDestination(LB1 To UB1, LB2 To UB2, LB3 To UB3, LB4 To UB4)
For i = LB1 To UB1
For j = LB2 To UB2
For k = LB3 To UB3
For l = LB4 To UB4
arrDestination(i, j, k, l) = arrSource(i, j, k, l)
Next l
Next k
Next j
Next i
End Sub
Public Sub CopyArrayContents3d(ByRef arrSource As Variant, ByRef arrDestination As Variant)
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
Dim LB3 As Long, UB3 As Long
Dim i As Long
Dim j As Long
Dim k As Long
Call AssignArrayBounds(arrSource, LB1, UB1, LB2, UB2, LB3, UB3)
Erase arrDestination
ReDim arrDestination(LB1 To UB1, LB2 To UB2, LB3 To UB3)
For i = LB1 To UB1
For j = LB2 To UB2
For k = LB3 To UB3
arrDestination(i, j, k) = arrSource(i, j, k)
Next k
Next j
Next i
End Sub
Public Sub CopyArrayContents2d(ByRef arrSource As Variant, ByRef arrDestination As Variant)
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
Dim i As Long
Dim j As Long
Call AssignArrayBounds(arrSource, LB1, UB1, LB2, UB2)
Erase arrDestination
ReDim arrDestination(LB1 To UB1, LB2 To UB2)
For i = LB1 To UB1
For j = LB2 To UB2
arrDestination(i, j) = arrSource(i, j)
Next j
Next i
End Sub
Public Sub CopyArrayContents1d(ByRef arrSource As Variant, ByRef arrDestination As Variant)
Dim LB1 As Long, UB1 As Long
Dim i As Long
Call AssignArrayBounds(arrSource, LB1, UB1)
Erase arrDestination
ReDim arrDestination(LB1 To UB1)
For i = LB1 To UB1
arrDestination(i) = arrSource(i)
Next i
End Sub
Public Sub AssignArrayBounds(ByRef arrCurrentArray As Variant, _
Optional ByRef LB1 As Variant, Optional ByRef UB1 As Variant, _
Optional ByRef LB2 As Variant, Optional ByRef UB2 As Variant, _
Optional ByRef LB3 As Variant, Optional ByRef UB3 As Variant, _
Optional ByRef LB4 As Variant, Optional ByRef UB4 As Variant, _
Optional ByRef LB5 As Variant, Optional ByRef UB5 As Variant)
If Not IsMissing(LB1) Then LB1 = LBound(arrCurrentArray, 1)
If Not IsMissing(UB1) Then UB1 = UBound(arrCurrentArray, 1)
If Not IsMissing(LB2) Then LB2 = LBound(arrCurrentArray, 2)
If Not IsMissing(UB2) Then UB2 = UBound(arrCurrentArray, 2)
If Not IsMissing(LB3) Then LB3 = LBound(arrCurrentArray, 3)
If Not IsMissing(UB3) Then UB3 = UBound(arrCurrentArray, 3)
If Not IsMissing(LB4) Then LB4 = LBound(arrCurrentArray, 4)
If Not IsMissing(UB4) Then UB4 = UBound(arrCurrentArray, 4)
If Not IsMissing(LB5) Then LB5 = LBound(arrCurrentArray, 5)
If Not IsMissing(UB5) Then UB5 = UBound(arrCurrentArray, 5)
End Sub
Public Sub ErrorMessage(ByVal strErrorMessage As String)
MsgBox strErrorMessage
Debug.Print strErrorMessage
Call RestoreApplicationSettings(varScreenUpdating, varEnableEvents, varCalculation)
End
End Sub
Public Sub Transpose2dArray(ByRef arrCurrentArray As Variant)
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
Dim i As Long
Dim j As Long
Call AssignArrayBounds(arrCurrentArray, LB1, UB1, LB2, UB2)
Dim arrTransposedArray() As Variant
ReDim arrTransposedArray(LB2 To UB2, LB1 To UB1)
For i = LB1 To UB1
For j = LB2 To UB2
arrTransposedArray(j, i) = arrCurrentArray(i, j)
Next j
Next i
Erase arrCurrentArray
ReDim arrCurrentArray(LB2 To UB2, LB1 To UB1)
Call CopyArrayContents2d(arrTransposedArray, arrCurrentArray)
End Sub
Public Sub StoreApplicationSettings(ByRef varScreenUpdating As Variant, ByRef varEnableEvents As Variant, ByRef varCalculation As Variant)
varScreenUpdating = Application.ScreenUpdating
varEnableEvents = Application.EnableEvents
varCalculation = Application.Calculation
End Sub
Public Sub DisableApplicationSettings()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
End Sub
Public Sub RestoreApplicationSettings(ByRef varScreenUpdating As Variant, ByRef varEnableEvents As Variant, ByRef varCalculation As Variant)
Application.ScreenUpdating = varScreenUpdating
Application.EnableEvents = varEnableEvents
Application.Calculation = varCalculation
End Sub
Public Sub GetWorkbook(ByVal strFilename As String, ByVal strFilePath As String)
Dim bIsWbOpen As Boolean
bIsWbOpen = IsWorkbookOpen(strFilename)
If bIsWbOpen = False Then Workbooks.Open strFilePath & strFilename
End Sub
Public Sub Print2dArrayToSheet(ByRef wbTarget As Workbook, ByRef wsTarget As Worksheet, ByRef arrData As Variant, ByRef rngStartCell As Range)
Dim LB1 As Long
Dim UB1 As Long
Dim LB2 As Long
Dim UB2 As Long
wbTarget.Activate
wsTarget.Activate
Call AssignArrayBounds(arrData, LB1, UB1, LB2, UB2)
Dim rngTableRange As Range
Set rngTableRange = Range(rngStartCell, Cells(rngStartCell.Row + UB1 - LB1, rngStartCell.Column + UB2 - LB2))
rngTableRange = arrData
End Sub
Public Sub CopyColumn2d(ByRef arrCurrentArray As Variant, ByRef arrDestination As Variant, ByVal lngSourcePosition As Long, ByVal lngDestinationPosition As Long)
'/ Copy column from one array to another
Dim i As Long
For i = LBound(arrCurrentArray) To UBound(arrCurrentArray)
arrDestination(i, lngDestinationPosition) = arrCurrentArray(i, lngSourcePosition)
Next i
End Sub
Good Sign: It went from an order of magnitude over the character limit to under it :)
