8
\$\begingroup\$

First off, this is the 3rd (and probably last) review of the project in question. You can find the previous question here.

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, there's been a significant amount of further refactoring, renaming subs/functions/variables and general incorporating of previous advice.

Since this is (hopefully) the end of this particular project, I would also appreciate feedback on what I'm doing right.

Module 1: M1_Public_Variables_Constants

N.B. I'm aware that making all the declarations line up like this isn't an efficient use of time, but since it's already been done, I'm not about to go and spend more time deliberately undoing it.

Option Explicit
Option Compare Text
'/ 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
Public WsChangedData As Worksheet '/ Record of Data CleanUp
'/ 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
Public colAdviserNames As Collection '/ All Adviser names that MIGHT be in the Subsheet
'/ 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 LngFinalCellRow As Long
Public LngFinalCellColumn As Long
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.5.xlsm" '/ The filename of the Adviser Submissions Report
Public Const StrSubsheetFilename As String = "Lumin Subsheet 2015.xlsm" '/ The filename of the Subsheet
Public Const Hyphen As String = " - "
Public varScreenUpdating As Boolean
Public varEnableEvents As Boolean
Public varCalculation As XlCalculation

Modules 2 - 4:

M2_Main_Subs

M3_Auxilary_Subs

M4_Manual_Settings

I elected to present them here in rough order of execution, as opposed to by Module. Any Sub/Function that isn't here will be in the Standard_Methods Module at the end.

GenerateAdviserSubmissionReports()

The initial sub to be run by the end user.

Public Sub GenerateAdviserSubmissionReports()
 StoreApplicationSettings
 
 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)
 '/======================================================================================================================================================
 '/======================================================================================================================================================
 InitialiseGlobalsBooksSheetsAndCollections
 
 GetAllSheetDataIntoArrays
 
 FilterSheetArrays
 
 AggregateSheetData
 
 CloseWorkbook WbSubsheet
 PrintAggregatedData
 
 CleanUpAggregatedData
 
 RestoreApplicationSettings
End Sub

InitialiseGlobalsBooksSheetsAndCollections

Set all the Globals, Collections etc. for the rest of the project.

Public Sub InitialiseGlobalsBooksSheetsAndCollections()
 Sheets(1).Activate
 LngFinalCellRow = Sheets(1).Rows.Count
 LngFinalCellColumn = Sheets(1).Columns.Count
 
 '/ initialise public arrays
 ArrAggregatedData = Array()
 ArrAggregatedArrays = Array()
 ArrProviders = Array()
 ArrAdvisers = Array()
 GetWorkbook StrAdviserReportFilename, StrAdviserReportFilePath
 Set WbAdviserReport = Workbooks(StrAdviserReportFilename)
 
 GetWorkbook StrSubsheetFilename, StrSubsheetFilePath
 Set WbSubsheet = Workbooks(StrSubsheetFilename)
 
 AssignWorksheets
 
 InitialiseCollections
 
End Sub

AssignWorksheets InitialiseCollections

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")
 Set WsChangedData = WbAdviserReport.Worksheets("Changed Data")
 
 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) & "/2015")
 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"
 
 
 Set colAdviserNames = New Collection
 colAdviserNames.Add "Martin Cotter", "Martin"
 colAdviserNames.Add "Jon Hussey", "Jon"
 colAdviserNames.Add "Micky Mahbubani", "Micky"
 colAdviserNames.Add "Jeremy Smith", "Jeremy"
 colAdviserNames.Add "Sarah Cotter", "Sarah"
 colAdviserNames.Add "John Cusins", "John"
 
End Sub

GetAllSheetDataIntoArrays

Private Sub GetAllSheetDataIntoArrays()
 '/======================================================================================================================================================
 '/ Author: Zak Armstrong
 '/ Email: [email protected]
 '/ Date: 28/August/2015
 '/
 '/ Description: Creates Arrays for each sheet, Calls sub to fill each with their sheet's data, collects arrays together in arrAggregatedArrys
 '/======================================================================================================================================================
 Dim arrNewClient As Variant
 arrNewClient = Array()
 
 Dim arrExistingClient As Variant
 arrExistingClient = Array()
 
 Dim arrGroupSchemes As Variant
 arrGroupSchemes = Array()
 
 Dim arrOther As Variant
 arrOther = Array()
 
 Dim arrMcOngoing As Variant
 arrMcOngoing = Array()
 
 Dim arrJhOngoing As Variant
 arrJhOngoing = Array()
 
 Dim arrAegonQuilterArc As Variant
 arrAegonQuilterArc = Array()
 
 Dim arrAscentric As Variant
 arrAscentric = Array()
 '/======================================================================================================================================================
 
 Dim strTopLeftCellIdentifier As String
 strTopLeftCellIdentifier = "Adviser"
 
 PutSheetDataInArray WbSubsheet, WsNewClient, arrNewClient, strTopLeftCellIdentifier
 PutSheetDataInArray WbSubsheet, WsExistingClient, arrExistingClient, strTopLeftCellIdentifier
 PutSheetDataInArray WbSubsheet, WsGroupSchemes, arrGroupSchemes, strTopLeftCellIdentifier
 PutSheetDataInArray WbSubsheet, WsOther, arrOther, strTopLeftCellIdentifier
 PutSheetDataInArray WbSubsheet, WsMcOngoing, arrMcOngoing, strTopLeftCellIdentifier
 PutSheetDataInArray WbSubsheet, WsJhOngoing, arrJhOngoing, strTopLeftCellIdentifier
 PutSheetDataInArray WbSubsheet, WsAegonQuilterArc, arrAegonQuilterArc, strTopLeftCellIdentifier
 
 strTopLeftCellIdentifier = "Account No"
 PutSheetDataInArray WbSubsheet, WsAscentric, arrAscentric, strTopLeftCellIdentifier
 
 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
 
End Sub

InsertAscentricLifeCoColumn

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
 '/======================================================================================================================================================
 
 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

FilterSheetArrays

Private Sub FilterSheetArrays()
 Dim i As Long
 Dim LB1 As Long, UB1 As Long
 
 AssignArrayBounds ArrAggregatedArrays, LB1, UB1
 
 For i = LB1 To UB1
 FilterSheetArrayForColumns ArrAggregatedArrays(i)
 Next i
 
End Sub

FilterSheetArraysForColumns

Private Sub FilterSheetArrayForColumns(ByRef arrSource 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, j As Long, k As Long
 
 Dim LB1 As Long, UB1 As Long
 Dim LB2 As Long, UB2 As Long
 
 Dim arrTempArray As Variant
 arrTempArray = Array()
 
 Dim arrHeadingsRow As Variant
 arrHeadingsRow = Array()
 '/======================================================================================================================================================
 
 AssignArrayBounds arrSource, LB1, UB1, LB2, UB2
 
 arrHeadingsRow = RowFrom2dArray(arrSource, 1)
 
 arrHeadingsRow = ElementsToStrings1dArray(arrHeadingsRow)
 
 ReDim arrTempArray(0 To UB1, 0 To ColAllHeadings.Count)
 arrTempArray(0, 0) = arrSource(0, 0)
 
 
 Dim lngDestinationColumn As Long
 Dim lngSourceColumn As Long
 
 Dim varColumnPosition As Variant
 
 Dim strHeading As String
 For i = 1 To ColAllHeadings.Count
 strHeading = ColAllHeadings(i)
 varColumnPosition = IndexInArray1d(arrHeadingsRow, strHeading)
 
 If IsError(varColumnPosition) _
 Then
 MissingDataHeadingsHandler arrSource, strHeading
 Else
 lngDestinationColumn = i
 lngSourceColumn = varColumnPosition
 
 CopyArrayColumn2d arrSource, lngSourceColumn, arrTempArray, lngDestinationColumn
 End If
 Next i
 
 arrSource = arrTempArray
 
End Sub

MissingDataHeadingsHandler

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
 InitialiseNewClientHeadingsExceptions colMissingSheetHeadings
 
 Case Is = WsExistingClient.Name
 InitialiseExistingClientHeadingsExceptions colMissingSheetHeadings
 
 
 Case Is = WsGroupSchemes.Name
 InitialiseGroupSchemesHeadingsExceptions colMissingSheetHeadings
 
 
 Case Is = WsOther.Name
 InitialiseOtherHeadingsExceptions colMissingSheetHeadings
 
 
 Case Is = WsMcOngoing.Name
 InitialiseMcOngoingHeadingsExceptions colMissingSheetHeadings
 
 
 Case Is = WsJhOngoing.Name
 InitialiseJhOngoingHeadingsExceptions colMissingSheetHeadings
 
 
 Case Is = WsAegonQuilterArc.Name
 InitialiseAegonQuilterArcHeadingsExceptions colMissingSheetHeadings
 
 
 Case Is = WsAscentric.Name
 InitialiseAscentricHeadingsExceptions colMissingSheetHeadings
 
 Case Else
 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 ErrorMessage (strErrorMessage)
End Sub

Initialise<Worksheet>HeadingsExceptions First one shown for illustration

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

AggregateSheetData

Private Sub AggregateSheetData()
 '/======================================================================================================================================================
 '/ Author: Zak Armstrong
 '/ Email: [email protected]
 '/ Date: 13/August/2015
 '/
 '/ Description: For Each array, add the data to arrAggregatedData
 '/======================================================================================================================================================
 Dim i As Long, j As Long, k As Long
 
 Dim rngTopLeftCell As Range
 
 Dim lngCurrentRow As Long
 
 Dim LB1 As Long, UB1 As Long
 Dim LB2 As Long, UB2 As Long
 '/======================================================================================================================================================
 ReDim ArrAggregatedData(1 To ColAllHeadings.Count, 1 To 1)
 
 lngCurrentRow = 1
 
 For i = 1 To ColAllHeadings.Count
 ArrAggregatedData(i, 1) = ColAllHeadings(i)
 Next i
 
 '/ All arrays were created as 0 - X, 0 - Y, hence LB + 1 and LB + 2
 For i = LBound(ArrAggregatedArrays) To UBound(ArrAggregatedArrays)
 
 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
 Transpose2dArray ArrAggregatedData
End Sub

PrintAggregatedData

Private Sub FilterSheetArrays()
 Dim i As Long
 Dim LB1 As Long, UB1 As Long
 
 AssignArrayBounds ArrAggregatedArrays, LB1, UB1
 
 For i = LB1 To UB1
 FilterSheetArrayForColumns ArrAggregatedArrays(i)
 Next i
 
End Sub

CleanUpAggregatedData

Private Sub CleanUpAggregatedData()
 '/======================================================================================================================================================
 '/ Author: Zak Armstrong
 '/ Email: [email protected]
 '/ Date: 13/August/2015
 '/
 '/ Description: Clean up the aggregated data table (converting shortened names to full names, removing in-sheet totals, replacing "N/A" etc.)
 '/ Makes a record of all changes (with the row for context) in the "Changed Data" sheet.
 '/======================================================================================================================================================
 Dim lngHeaderEndColumn As Long
 
 Dim LB1 As Long, UB1 As Long
 Dim LB2 As Long, UB2 As Long
 
 Dim arrChangedData As Variant
 arrChangedData = Array()
 '/======================================================================================================================================================
 
 CreateHeadingChangedData arrChangedData, lngHeaderEndColumn
 
 AssignRangeBoundsOfData WsAggregatedData.Cells(1, 1), LB1, UB1, LB2, UB2
 
 RemoveUnwantedData arrChangedData, lngHeaderEndColumn, LB1, UB1, LB2, UB2
 
 Transpose2dArray arrChangedData
 
 Print2dArrayToSheet WbAdviserReport, WsChangedData, arrChangedData, WsChangedData.Cells(1, 1)
 
 AssignRangeBoundsOfData WsAggregatedData.Cells(1, 1), LB1, UB1, LB2, UB2
 
 ChangeAdviserNames lngHeaderEndColumn, LB1, UB1, LB2, UB2
End Sub

CreateHeadingChangedData

Public Sub CreateHeadingChangedData(ByRef arrChangedData As Variant, ByRef lngHeaderEndColumn As Long)
Dim i As Long
 
 ReDim arrChangedData(1 To ColAllHeadings.Count + 4, 1 To 1)
 
 arrChangedData(1, 1) = "Trigger Value"
 arrChangedData(2, 1) = "Row"
 arrChangedData(3, 1) = "Action"
 lngHeaderEndColumn = 3 + 1
 
 For i = 1 To ColAllHeadings.Count
 arrChangedData(lngHeaderEndColumn + i, 1) = ColAllHeadings(i)
 Next i
End Sub

CreateHeadingChangedData

Public Sub RemoveUnwantedData(ByRef arrChangedData As Variant, ByRef lngHeaderEndColumn As Long, ByRef LB1 As Long, ByRef UB1 As Long, ByRef LB2 As Long, ByRef UB2 As Long)
 
 Dim rngHolder As Range
 Dim i As Long, j As Long
 
 WbAdviserReport.Activate
 WsAggregatedData.Activate
 
 For i = UB1 To LB1 + 1 Step -1
 
 Set rngHolder = Cells(i, LB2)
 If rngHolder.Text = "Total" Then RemoveRow arrChangedData, lngHeaderEndColumn, rngHolder, LB2, UB2
 
 '/ Numeric Columns: (1) + 5 (Date Submitted) (1) + (7 - 25) (Inv. amount, premiums, commissions, Jan 2015 - Dec 2015)
 Set rngHolder = Cells(i, LB2 + 5)
 If Not (IsNumeric(rngHolder.Value) Or IsDate(rngHolder.Value)) Then RemoveCellContents arrChangedData, lngHeaderEndColumn, rngHolder, LB2, UB2
 
 For j = 7 To 25
 Set rngHolder = Cells(i, LB2 + j)
 If Not (IsNumeric(rngHolder.Value) Or IsDate(rngHolder.Value)) Then RemoveCellContents arrChangedData, lngHeaderEndColumn, rngHolder, LB2, UB2
 Next j
 
 Next i
 
End Sub

RemoveCellContents RemoveRow

Public Sub RemoveCellContents(ByRef arrChangedData As Variant, ByVal lngHeaderEndColumn As Long, ByRef rngTargetCell As Range, ByVal lngFirstColumn As Long, ByVal lngFinalColumn As Long)
 Dim lngCurrentRow As Long
 Dim lngFinalRow As Long
 
 Dim lngRowLength As Long
 lngRowLength = lngFinalColumn - lngFirstColumn + 1
 
 Dim rngTargetRow As Range
 
 Dim i As Long
 
 Dim arrTemp() As Variant
 ReDim arrTemp(1 To lngRowLength) As Variant
 
 lngCurrentRow = rngTargetCell.Row
 For i = lngFirstColumn To lngFinalColumn
 arrTemp(i) = WsAggregatedData.Cells(lngCurrentRow, i).Value
 Next i
 
 Dim LB1 As Long, UB1 As Long
 Dim LB2 As Long, UB2 As Long
 
 AssignArrayBounds arrChangedData, LB1, UB1, LB2, UB2
 ReDim Preserve arrChangedData(LB1 To UB1, LB2 To UB2 + 1)
 
 For i = 1 To lngRowLength
 arrChangedData(lngHeaderEndColumn + i, UB2 + 1) = arrTemp(i)
 Next i
 
 arrChangedData(1, UB2 + 1) = rngTargetCell.Value
 arrChangedData(2, UB2 + 1) = "Row: " & rngTargetCell.Row
 arrChangedData(3, UB2 + 1) = "Cleared Contents"
 
 rngTargetCell.ClearContents
End Sub
Public Sub RemoveRow(ByRef arrChangedData As Variant, ByVal lngHeaderEndColumn As Long, ByRef rngTargetCell As Range, ByVal lngFirstColumn As Long, ByVal lngFinalColumn As Long)
 Dim lngCurrentRow As Long
 Dim lngFinalRow As Long
 
 Dim lngRowLength As Long
 lngRowLength = lngFinalColumn - lngFirstColumn + 1
 
 Dim rngTargetRow As Range
 
 Dim i As Long
 
 Dim arrTemp() As Variant
 ReDim arrTemp(1 To lngRowLength) As Variant
 
 lngCurrentRow = rngTargetCell.Row
 For i = lngFirstColumn To lngFinalColumn
 arrTemp(i) = WsAggregatedData.Cells(lngCurrentRow, i).Value
 Next i
 
 Dim LB1 As Long, UB1 As Long
 Dim LB2 As Long, UB2 As Long
 
 AssignArrayBounds arrChangedData, LB1, UB1, LB2, UB2
 ReDim Preserve arrChangedData(LB1 To UB1, LB2 To UB2 + 1)
 
 For i = 1 To lngRowLength
 arrChangedData(lngHeaderEndColumn + i, UB2 + 1) = arrTemp(i)
 Next i
 
 arrChangedData(1, UB2 + 1) = rngTargetCell.Value
 arrChangedData(2, UB2 + 1) = "Row: " & rngTargetCell.Row
 arrChangedData(3, UB2 + 1) = "Deleted Row"
 
 Rows(lngCurrentRow).Delete
End Sub

ChangeAdviserNames

Public Sub ChangeAdviserNames(ByRef lngHeaderEndColumn As Long, ByRef LB1 As Long, ByRef UB1 As Long, ByRef LB2 As Long, ByRef UB2 As Long)
 WbAdviserReport.Activate
 WsAggregatedData.Activate
 
 Dim rngHolder As Range
 
 Dim i As Long, j As Long
 
 Dim bError As Boolean
 
 Dim strErrorMessage As String
 
 For i = UB1 To LB1 + 1 Step -1
 
 Set rngHolder = Cells(i, LB2)
 
 Select Case rngHolder.Text
 
 Case Is = "Jon"
 rngHolder.Value = colAdviserNames.Item(rngHolder.Text)
 
 Case Is = "Martin"
 rngHolder.Value = colAdviserNames.Item(rngHolder.Text)
 
 Case Is = "Micky"
 rngHolder.Value = colAdviserNames.Item(rngHolder.Text)
 
 Case Is = "Jeremy"
 rngHolder.Value = colAdviserNames.Item(rngHolder.Text)
 
 Case Is = "John"
 rngHolder.Value = colAdviserNames.Item(rngHolder.Text)
 
 Case Is = "Sarah"
 rngHolder.Value = colAdviserNames.Item(rngHolder.Text)
 
 Case Else
 bError = True
 
 For j = 1 To colAdviserNames.Count
 If rngHolder.Text = colAdviserNames(j) Then bError = False
 Next j
 
 If bError _
 Then
 strErrorMessage = "Unidentified Adviser - Row: " & i & "Text: " & rngHolder.Text
 ErrorMessage (strErrorMessage)
 End If
 
 End Select
 
 Next i
End Sub

Module 0: M0_Standard_Methods.

N.B. if you have any advice relating purely to the standard methods (and not, for instance, how they're used in the main project), I have a separate question for that

Option Explicit
Option Compare Text
Public Sub GetWorkbook(ByVal strFilename As String, ByVal strFilePath As String)
 Dim bWbIsOpen As Boolean
 
 bWbIsOpen = WorkbookIsOpen(strFilename)
 If Not bWbIsOpen Then Workbooks.Open strFilePath & strFilename
End Sub
Public Function WorkbookIsOpen(ByVal strTargetName As String) As Boolean
 Dim wbTest As Workbook
 On Error Resume Next
 Set wbTest = Workbooks(strTargetName)
 WorkbookIsOpen = (wbTest.Name = strTargetName)
 On Error GoTo 0
End Function
Public Sub PutSheetDataInArray(ByRef wbCurrent As Workbook, ByRef wsCurrent As Worksheet, ByRef arrCurrentArray As Variant, Optional ByVal strTopLeftCellIdentifier As Variant, _
Optional ByVal lngStartRow As Long = 1, Optional ByVal lngEndRow As Variant, _
Optional ByVal lngStartColumn As Long = 1, Optional ByVal lngEndColumn As Variant)
 '/======================================================================================================================================================
 Dim i As Long, j As Long, k As Long
 
 Dim rngTopLeftCell As Range
 Dim rngSearchRange As Range
 
 Dim strErrorMessage As String
 
 Dim arrHiddenColumns As Variant
 arrHiddenColumns = Array()
 
 Dim arrHiddenRows As Variant
 arrHiddenRows = Array()
 
 Dim LB1 As Long, UB1 As Long
 Dim LB2 As Long, UB2 As Long
 '/======================================================================================================================================================
 wbCurrent.Activate
 wsCurrent.Activate
 
 If IsMissing(strTopLeftCellIdentifier) _
 Then
 Set rngTopLeftCell = Cells(1, 1)
 ElseIf TypeName(strTopLeftCellIdentifier) = "String" _
 Then
 If IsMissing(lngEndRow) Then lngEndRow = wsCurrent.Rows.Count
 If IsMissing(lngEndColumn) Then lngEndColumn = wsCurrent.Columns.Count
 
 Set rngSearchRange = wsCurrent.Range(Cells(lngStartRow, lngStartColumn), Cells(lngEndRow, lngEndColumn))
 Set rngTopLeftCell = CellContainingStringInRange(rngSearchRange, strTopLeftCellIdentifier)
 Else
 strErrorMessage = "strTopLeftCellIdentifier must be a string, not a " & TypeName(strTopLeftCellIdentifier)
 ErrorMessage (strErrorMessage)
 End If
 
 
 LB1 = rngTopLeftCell.Row
 LB2 = rngTopLeftCell.Column
 AssignRangeBoundsOfData rngTopLeftCell, UB1:=UB1, UB2:=UB2
 
 RecordHiddenRowsAndUnhide arrHiddenRows, LB1, UB1
 RecordHiddenColumnsAndUnhide arrHiddenColumns, LB2, UB2
 
 WriteRangeToArrayIteratively wsCurrent, arrCurrentArray, LB1, UB1, LB2, UB2
 
 HideRows arrHiddenRows
 HideColumns arrHiddenColumns
 
End Sub
Public Function CellContainingStringInRange(ByRef rngSearch As Range, ByVal strSearch As String) As Range
 Dim strErrorMessage As String
 
 Set CellContainingStringInRange = rngSearch.Find(strSearch, LookIn:=xlValues)
 
 If CellContainingStringInRange Is Nothing _
 Then
 strErrorMessage = "Couldn't find cell """ & strSearch & """ in " & rngSearch.Worksheet.Name
 ErrorMessage (strErrorMessage)
 End If
 
End Function
Public Sub RecordHiddenRowsAndUnhide(ByRef arrHiddenRows As Variant, ByVal LB1 As Long, ByVal UB1 As Long)
 
 Dim i As Long
 
 Dim lngCounter As Long
 
 For i = LB1 To UB1
 If Rows(i).EntireRow.Hidden _
 Then
 lngCounter = lngCounter + 1
 ReDim Preserve arrHiddenRows(1 To lngCounter)
 arrHiddenRows(lngCounter) = i
 Rows(i).Hidden = False
 End If
 Next i
 
End Sub
Public Sub RecordHiddenColumnsAndUnhide(ByRef arrHiddenColumns As Variant, ByVal LB2 As Long, ByVal UB2 As Long)
 
 Dim i As Long
 
 Dim lngCounter As Long
 
 For i = LB2 To UB2
 If Columns(i).EntireRow.Hidden _
 Then
 lngCounter = lngCounter + 1
 ReDim Preserve arrHiddenColumns(1 To lngCounter)
 arrHiddenColumns(lngCounter) = i
 Columns(i).Hidden = False
 End If
 Next i
 
End Sub
Public Sub HideRows(ByRef arrHiddenRows As Variant)
 Dim i As Long
 
 For i = LBound(arrHiddenRows) To UBound(arrHiddenRows)
 Rows(i).EntireRow.Hidden = True
 Next i
 
End Sub
Public Sub HideColumns(ByRef arrHiddenColumns As Variant)
 Dim i As Long
 
 For i = LBound(arrHiddenColumns) To UBound(arrHiddenColumns)
 Columns(i).EntireRow.Hidden = True
 Next i
 
End Sub
Public Sub AssignRangeBoundsOfData(ByRef rngCell As Range, Optional ByRef LB1 As Variant, Optional ByRef UB1 As Variant, Optional ByRef LB2 As Variant, Optional ByRef UB2 As Variant)
 Dim wbCurrent As Workbook
 Dim wsCurrent As Worksheet
 
 AssignCurrentBookAndSheet wbCurrent, wsCurrent
 
 Dim wsRngCell As Worksheet
 Dim wbRngCell As Workbook
 
 AssignRangeBookAndSheet rngCell, wbRngCell, wsRngCell
 
 wbRngCell.Activate
 wsRngCell.Activate
 
 Dim rngCurrentRegion As Range
 Set rngCurrentRegion = rngCell.CurrentRegion
 
 If Not IsMissing(LB1) Then LB1 = rngCurrentRegion.Row
 If Not IsMissing(LB2) Then LB2 = rngCurrentRegion.Column
 
 If Not IsMissing(UB1) Then UB1 = rngCurrentRegion.Row + rngCurrentRegion.Rows.Count - 1
 If Not IsMissing(UB2) Then UB2 = rngCurrentRegion.Column + rngCurrentRegion.Columns.Count - 1
 
 wbCurrent.Activate
 wsCurrent.Activate
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, j As Long, k As Long
 Dim l As Long, m As Long
 
 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, j As Long, k As Long
 Dim l As Long
 
 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, j As Long, k As Long
 
 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, j As Long
 
 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
 
 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 Transpose2dArray(ByRef arrCurrentArray As Variant)
 Dim LB1 As Long, UB1 As Long
 Dim LB2 As Long, UB2 As Long
 
 Dim i As Long, j As Long
 
 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)
 
 arrCurrentArray = arrTransposedArray
 
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, UB1 As Long
 Dim LB2 As Long, UB2 As Long
 
 Dim rngTableRange As Range
 
 wbTarget.Activate
 wsTarget.Activate
 
 AssignArrayBounds arrData, LB1, UB1, LB2, UB2
 Set rngTableRange = Range(rngStartCell, Cells(rngStartCell.Row + UB1 - LB1, rngStartCell.Column + UB2 - LB2))
 rngTableRange = arrData
End Sub
Public Sub CopyArrayColumn2d(ByRef arrSource As Variant, ByVal lngSourceColumn As Long, ByRef arrTarget As Variant, ByVal lngTargetColumn As Long)
 Dim i As Long, j As Long, k As Long
 
 Dim LB1 As Long, UB1 As Long
 
 AssignArrayBounds arrSource, LB1, UB1
 
 For i = LB1 To UB1
 arrTarget(i, lngTargetColumn) = arrSource(i, lngSourceColumn)
 Next i
 
End Sub
Public Function RowFrom2dArray(ByRef arrSource As Variant, ByVal lngRow As Long) As Variant
 Dim LB2 As Long, UB2 As Long
 Dim i As Long
 
 Dim arrRow As Variant
 arrRow = Array()
 
 AssignArrayBounds arrSource, LB2:=LB2, UB2:=UB2
 
 ReDim arrRow(LB2 To UB2)
 
 For i = LB2 To UB2
 arrRow(i) = arrSource(lngRow, i)
 Next i
 
 RowFrom2dArray = arrRow
 
End Function
Public Function IndexInArray1d(ByRef arrSource As Variant, ByVal varSearch As Variant) As Variant
 Dim LB1 As Long, UB1 As Long
 
 Dim bMatchFound As Boolean
 
 Dim i As Long
 
 AssignArrayBounds arrSource, LB1, UB1
 bMatchFound = False
 
 i = LB1
 Do While i <= UB1 And bMatchFound = False
 If arrSource(i) = varSearch _
 Then
 bMatchFound = True
 IndexInArray1d = i
 End If
 i = i + 1
 Loop
 
 If Not bMatchFound Then IndexInArray1d = CVErr(xlErrValue)
 
End Function
Public Sub AssignCurrentBookAndSheet(ByRef wbCurrent As Workbook, ByRef wsCurrent As Worksheet)
 Set wbCurrent = ThisWorkbook
 Set wsCurrent = ActiveSheet
 
End Sub
Public Sub AssignRangeBookAndSheet(ByRef rngTarget As Range, ByRef wbTarget As Workbook, ByRef wsTarget As Worksheet)
 Set wbTarget = rngTarget.Worksheet.Parent
 Set wsTarget = rngTarget.Worksheet
 
End Sub
Public Sub WriteRangeToArrayIteratively(ByRef wsCurrent As Worksheet, arrCurrentArray As Variant, ByVal LB1 As Long, ByVal UB1 As Long, ByVal LB2 As Long, ByVal UB2 As Long)
 Dim i As Long, j As Long
 
 wsCurrent.Activate
 
 ReDim arrCurrentArray(0 To UB1 - LB1 + 1, 0 To UB2 - LB2 + 1)
 arrCurrentArray(0, 0) = wsCurrent.Name
 
 For i = LB1 To UB1
 For j = LB2 To UB2
 arrCurrentArray(i - LB1 + 1, j - LB2 + 1) = wsCurrent.Cells(i, j)
 Next j
 Next i
 
End Sub
Public Function ElementsToStrings1dArray(ByRef arrSource As Variant) As Variant
 Dim i As Long
 Dim arrRow As Variant
 arrRow = arrSource
 
 For i = LBound(arrSource) To UBound(arrSource)
 arrRow(i) = CStr(arrRow(i))
 Next i
 
 ElementsToStrings1dArray = arrRow
 
End Function
Public Sub ErrorMessage(ByVal strErrorMessage As String)
 MsgBox strErrorMessage
 Debug.Print strErrorMessage
 RestoreApplicationSettings
 Stop
End Sub
Public Sub StoreApplicationSettings()
 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()
 Application.ScreenUpdating = varScreenUpdating
 Application.EnableEvents = varEnableEvents
 Application.Calculation = varCalculation
 
End Sub
Public Sub CloseWorkbook(ByRef wbTarget As Workbook)
 Application.DisplayAlerts = False
 wbTarget.Close
 Application.DisplayAlerts = True
End Sub
asked Aug 30, 2015 at 15:14
\$\endgroup\$

2 Answers 2

2
\$\begingroup\$

Some parts that look a bit questionable:
use of select case to do the same actions

Select Case rngHolder.Text
Case Is = "Jon"
 rngHolder.Value = colAdviserNames.Item(rngHolder.Text)
Case Is = "Martin"
 rngHolder.Value = colAdviserNames.Item(rngHolder.Text)
....

why not simply:

Select Case rngHolder.Text
Case "Jon", "Martin", "Micky", "Jeremy", "John", "Sarah"
 rngHolder.Value = colAdviserNames.Item(rngHolder.Text)
Case Else
 bError = True
 ....

Or do it directly

If IsNumeric(Application.Match(rngHolder.Text, Array("Jon", "Martin", "Micky", "Jeremy", "John", "Sarah"), 0)) Then
 rngHolder.Value = colAdviserNames.Item(rngHolder.Text)
Else
 bError = True
 ....

However, while the last one is faster for bigger arrays to check, it is a bit overpowered for this simple task :)


dim lots of variables which act in the same behavior
Mainly used at AssignArrayBounds:

AssignArrayBounds arrSource, LB1, UB1, LB2, UB2, LB3, UB3, LB4, UB4, LB5, UB5

Till now, your code is pretty much clean and easy to read, except for getting the upper and lower bounds, but using it like here it could be simplyfied (at least for my eye) by changing AssignArrayBounds like this:

Public Sub AssignArrayBounds(ArrayToCheck As Variant, LowerBound() As Long, Upperbound() As Long, Optional NumDimensions As Byte = 1)
 Dim i As Byte
 ReDim LowerBound(NumDimensions)
 ReDim Upperbound(NumDimensions)
 For i = 1 To NumDimensions
 LowerBound(i) = LBound(ArrayToCheck, i)
 Upperbound(i) = UBound(ArrayToCheck, i)
 Next
End Sub

For your 5D-array it now would look like this:

Dim LB() as Long
Dim UB() as Long
AssignArrayBounds arrSource, LB, UB, 5

At the other hand you would need to change For k = LB3 To UB3 to For k = LB(3) To UB(3) which is not much more unreadable for my eye. But this may count just for the coding-habit-section ;)


loops for creating copy-arrays being the same data-type
However, the last point leads me to something i don't get at all:

Public Sub CopyArrayContents*d(ByRef arrSource As Variant, ByRef arrDestination As Variant)

You call it to ReDim the second array and then looping through all items. But having both as ByRef ... As Variant I don't know why you not simply use:

arrDestination = arrSource

Which would make your second array to a perfect copy on one step (and doing that a LOT faster)... counting 1 and 1 together, there is no reason for this sub at all.
You could not simply use arrDestination{Long} = arrSource{Double} but you sub needs both arrays to be variant, which makes it obsolete (but i may miss something big here again)


public variables i just don't get
To start easy Public Const Hyphen As String = " - ". To me it would make sense if it contains something special like tabulator or holds at least more chars than the variable-name has.
Public varScreenUpdating As Boolean and Public varEnableEvents As Boolean are like... umm... honestly, why??? If they need to be turned on/off just do it. I simply don't get the reason for them. As soon as the VBA-execution ends, they will be turned on again, no matter what. There just a few situations (errors) which prevent it to be turned on again, but all of them would also prevent the macro to turn it on again to run. No need to speak it out, but Public varCalculation As XlCalculation is something different so i would not touch it. However: [Re]StoreApplicationSettings now would only contain one line of code which would make the sub obsolete, cus you could run that line directly.


every interaction with a real worksheet is MUCH slower than with a variable-array
Looking at WriteRangeToArrayIteratively there may be a bunch of interactions that will slow down the whole execution:

For i = LB1 To UB1
 For j = LB2 To UB2
 arrCurrentArray(i - LB1 + 1, j - LB2 + 1) = wsCurrent.Cells(i, j)
 Next j
Next i

Should be changed to increase greatly the speed while this decreases the legibility. Just using that sniped of code, i would change it to:

Dim tempRange As Variant
tempRange = wsCurrent.Range(Cells(LB1, LB2), Cells(UB1, UB2)).Value
UB1 = UB1 - LB1 + 1
UB2 = UB2 - LB2 + 1
For i = 1 To UB1
 For j = 1 To UB2
 arrCurrentArray(i, j) = tempRange(i, j)
 Next j
Next i

Having the upper left cell of tempRange always being (1, 1) you would need to also use (i - LB1 + 1, j - LB2 + 1) so i changed the UB* to use i and j directly.


As a small speed-test: (just skip reading this part if you are aware of that)

Sub comp1()
 Dim a As Variant, b As String, i As Long, j As Long, c As Double
 c = Now
 For i = 1 To 1000000 'cycles
 a = Range("A1:A2").Value
 For j = 1 To 2
 b = a(j, 1)
 Next
 Next
 c = Now - c
 Debug.Print c * 24 * 60 * 60
End Sub
Sub comp2()
 Dim a As Variant, b As String, i As Long, j As Long, c As Double
 c = Now
 For i = 1 To 1000000 'cycles
 For j = 1 To 2
 b = Cells(j, 1).Value
 Next
 Next
 c = Now - c
 Debug.Print c * 24 * 60 * 60
End Sub

This 2 subs will output ~ the same time. The bigger the range gets the more comp1 will speed out comp2. At a range of 3 cells there is already a noticeable difference. Having a range of 100 cells and 10000 cycles comp1 will probably just print a 0 while comp 2 takes some seconds. Also take into account that Cells(1, 1) will be ~66% faster than Range("A1") and normally there will be multiple checks and not only 1 get, so the more you interact with the sheet, the faster you will get by using a variable. Feel free to play a bit with this subs.
Hint: never use something like [A1]... while it may look cool it is just extremely slow...


always set variant = Array()

While it is ok for special cases i can't see any reason for doing something like this here. If you use a variant always as an array you simply could directly declare it that way...

Dim MyArray as Variant
 MyArray = Array()
MySub Myarray
Sub MySub(ByRef SpecialArray as Variant)
 Redim SpecialArray(x to y)
...

Simply could be changed to:

Dim MyArray() as Variant
MySub Myarray
Sub MySub(ByRef SpecialArray() as Variant)
 Redim SpecialArray(x to y)
...

There is no need to endlessly set it to an empty array if you never use it in a non-array way.


miscellaneous


Why use ElementsToStrings1dArray as function? Is somewhere a different use than arrHeadingsRow = ElementsToStrings1dArray(arrHeadingsRow)? That said Transpose2dArray would make sense to being a function having it be set Transpose2dArray = arrTransposedArray at the end. Also having the desired coding Array1 = Array2 at the end, there is no need to ReDim Array1 (it will become a copy and auto ReDimmed to the ranges of Array2.


You could change

Public Sub HideColumns(ByRef arrHiddenColumns As Variant)
 Dim i As Long
 For i = LBound(arrHiddenColumns) To UBound(arrHiddenColumns)
 Columns(i).EntireRow.Hidden = True
 Next i
End Sub

to

Public Sub HideColumns(ByRef arrHiddenColumns As Variant)
 Range(Columns(LBound(arrHiddenColumns), Columns(UBound(arrHiddenColumns)).Hidden = True
End Sub

Leads to => one line of code => sub can be skipped (same goes for Hide Rows). At least it will be much faster doing this in one step.


Speedup also goes for RecordHiddenRowsAndUnhide/RecordHiddenColumnsAndUnhide:

Public Sub RecordHiddenRowsAndUnhide(ByRef arrHiddenRows As Variant, ByVal LB1 As Long, ByVal UB1 As Long)
 Dim i As Long
 Dim lngCounter As Long
 For i = LB1 To UB1
 If Rows(i).EntireRow.Hidden Then
 lngCounter = lngCounter + 1
 ReDim Preserve arrHiddenRows(1 To lngCounter)
 arrHiddenRows(lngCounter) = i
 Rows(i).Hidden = False
 End If
 Next i
End Sub

can be changed to

Public Sub RecordHiddenRowsAndUnhide(ByRef arrHiddenRows As Variant, ByVal LB1 As Long, ByVal UB1 As Long)
 Dim hRow As Variant, rng As Range, hiddenRows As Long
 Set rng = Range(Rows(LB1), Rows(UB1)) 'get all rows in range
 For Each hRow In rng
 If Not hRow.Hidden Then 'check for each rob to be visible
 hiddenRows = rng.roes.Count - rng.Columns(1).SpecialCells(xlCellTypeVisible).Count 'get the number if hidden rows
 If hiddenrows > 0 Then ReDim Preserve arrHiddenRows(1 To hiddenRows) 'set the array if at least 1 row is hidden
 rng.Hidden = False 'unhide all rows
 Exit Sub 'everything is done get out here :)
 End If
 Next
 ReDim Preserve arrHiddenRows(1 To rng.Rows.Count) 'no visible row found - set to count of rows
 rng.Hidden = False 'unhide all rows
End Sub

While it is more code now, it should also be much faster. Just running for the first visible row and then count all rows in range minus visible rows. It gets a bit confusing for the count of visible rows using the SpecialCells. rng.SpecialCells(xlCellTypeVisible).Rows.Count will just count the rows from the first visible till the next hidden one. So i go with rng.Columns(1) and then count the cells.


Assuming you do not open thousands of workbooks at the same time and then check for it endlessly. Try to avoid errors at all cost (they should not be part of coding)

Public Function WorkbookIsOpen(ByVal strTargetName As String) As Boolean
 Dim wbTest As Workbook
 On Error Resume Next
 Set wbTest = Workbooks(strTargetName)
 WorkbookIsOpen = (wbTest.Name = strTargetName)
 On Error GoTo 0
End Function

this (削除) can (削除ここまで) should be changed to:

Public Function WorkbookIsOpen(ByVal strTargetName As String) As Boolean
 Dim wbTest As Workbook
 For Each wbTest In Workbooks
 If wbTest.Name = strTargetName Then
 WorkbookIsOpen = True
 Exit Function
 End If
 Next
End Function

To get into the coding-habit-corner again, I would change something like

AssignRangeBoundsOfData rngTopLeftCell, UB1:=UB1, UB2:=UB2

to

AssignRangeBoundsOfData rngTopLeftCell, , UB1, , UB2

Simply cus it is obvious by the variable-names itself.


Looking at speed again and avoid doing checks for ranges which are simply not used, consider using UsedRange like

If IsMissing(lngEndRow) Then lngEndRow = wsCurrent.Rows.Count
If IsMissing(lngEndColumn) Then lngEndColumn = wsCurrent.Columns.Count

becomes

If IsMissing(lngEndRow) Then lngEndRow = wsCurrent.UsedRange.Rows.Count
If IsMissing(lngEndColumn) Then lngEndColumn = wsCurrent.UsedRange.Columns.Count

While knowing you are going to use Find for this range (which always just checks inside the UsedRange). Find is still the best way to improve the calculation-time by a big amount


You always use For ... Next which is ok for most cases, but then you pop something like this

Public Function IndexInArray1d(ByRef arrSource As Variant, ByVal varSearch As Variant) As Variant
 Dim LB1 As Long, UB1 As Long
 Dim bMatchFound As Boolean
 Dim i As Long
 AssignArrayBounds arrSource, LB1, UB1
 bMatchFound = False
 i = LB1
 Do While i <= UB1 And bMatchFound = False
 If arrSource(i) = varSearch Then
 bMatchFound = True
 IndexInArray1d = i
 End If
 i = i + 1
 Loop
 If Not bMatchFound Then IndexInArray1d = CVErr(xlErrValue)
End Function

Going from a lower value to a higher one is the very best reason to use For ... Next. Is it just for the bMatchFound? Why not do it this way:

Public Function IndexInArray1d(ByRef arrSource As Variant, ByVal varSearch As Variant) As Variant
 Dim LB1 As Long, UB1 As Long
 Dim i As Long
 AssignArrayBounds arrSource, LB1, UB1
 For i = LB1 To UB1
 If arrSource(i) = varSearch Then
 IndexInArray1d = i
 Exit Function
 End If
 Next
 IndexInArray1d = CVErr(xlErrValue)
End Function

If you are sure to not trigger the 255-character-error you also could use Application.Match which also returns an error if nothing was found, but you would need to set it to a variable and later add + LB1 - 1 to get the pos inside the array. (To me it looks like you either tried to do something different or you got bored of it at this point) :D


For now that's all i consider as being worth to mention (I will skip the parts already inside the answer of Mat's Mug)

While some of the suggestions are easily done "on the run" others need bigger changes (for less benefit). And i don't know how much speed matters at this point. Also there lots of parts which are not shown here and will not work with my suggestions or may even lead to worsening/slow down. That said, YOU need to understand what's happening at all times (everything else comes later).

Hopefully I was at least able to throw you 1 or 2 ideas for future projects.

Note: Would be happy if someone could check my spelling/formatting and then delete this note. Thanks

answered Dec 15, 2015 at 7:15
\$\endgroup\$
4
  • \$\begingroup\$ I don't know how I missed this answer but I did. Awesome advice. Cheers! \$\endgroup\$ Commented Dec 22, 2015 at 17:54
  • 1
    \$\begingroup\$ wrt dimming arrays as arrays, not variants, I prefer variants because a variant/array can do things that an array can't. (I think the catalyst for this was wanting to pass an Array, stored in another array, as an argument to a function, and since functions get upset if they get a variant/array instead of an arr(), I figured I'd move to always creating my arrays that way. \$\endgroup\$ Commented Dec 22, 2015 at 17:59
  • \$\begingroup\$ Apart from that, and some minor personal differences over readability, this is an awesome answer, thanks again! \$\endgroup\$ Commented Dec 22, 2015 at 18:07
  • \$\begingroup\$ Thanks... Normally I only look at speed (minimizing the amount of calculations and all that stuff)... Always having in mind: could it be done in a different way? Still knowing different doesn't means "better". At least: if I'm able to give you some ideas for this or other projects, i consider my job as "accomplished". Still knowing "You can make that readable later" :P \$\endgroup\$ Commented Dec 22, 2015 at 18:22
5
\$\begingroup\$

I'm aware that making all the declarations line up like this isn't an efficient use of time, but since it's already been done, I'm not about to go and spend more time deliberately undoing it.

Thanks, you just made a feature request for Rubberduck 2.0!


You have object references - why do you use Activate?

WbAdviserReport.Activate
WsAggregatedData.Activate
...
Set rngHolder = Cells(i, LB2)

Instead of an implicit reference to the active worksheet (with the Cells call), use an explicit reference, and get rid of the Activate calls:

Set rngHolder = WsAggregatedData.Cells(i, LB2)

I like this, but I don't get why you need the line continuation here, nor why you're forcing strErrorMessage to be passed ByVal, since ErrorMessage already states that the strErrorMessage parameter is passed by value:

If bError _
 Then
 strErrorMessage = "Unidentified Adviser - Row: " & i & "Text: " & rngHolder.Text
 ErrorMessage (strErrorMessage)
End If

should be this:

If bError Then
 strErrorMessage = "Unidentified Adviser - Row: " & i & "Text: " & rngHolder.Text
 ErrorMessage strErrorMessage
End If

Why does MissingDataHeadingsHandler spell the condition differently?

If bErrorFound = True Then ErrorMessage (strErrorMessage)

should be:

If bErrorFound Then ErrorMessage strErrorMessage

Again, the off-standard indentation is a bit off-putting, and I'm not sure what to think of the vertical whitespace:

Public Function WorkbookIsOpen(ByVal strTargetName As String) As Boolean
 Dim wbTest As Workbook
 On Error Resume Next
 Set wbTest = Workbooks(strTargetName)
 WorkbookIsOpen = (wbTest.Name = strTargetName)
 On Error GoTo 0
End Function

I'd have formatted it like this:

Public Function WorkbookIsOpen(ByVal strTargetName As String) As Boolean
 On Error Resume Next
 Dim wbTest As Workbook
 Set wbTest = Workbooks(strTargetName)
 WorkbookIsOpen = (wbTest.Name = strTargetName)
 On Error GoTo 0
End Function

Notice the variable is declared closer to its usage, and that all executable instructions are at the same level of indentation - but I don't completely disagree with treating On Error Resume Next...On Error GoTo 0 as a code block.

answered Dec 4, 2015 at 18:47
\$\endgroup\$

Your Answer

Draft saved
Draft discarded

Sign up or log in

Sign up using Google
Sign up using Email and Password

Post as a guest

Required, but never shown

Post as a guest

Required, but never shown

By clicking "Post Your Answer", you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.