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
2 Answers 2
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
-
\$\begingroup\$ I don't know how I missed this answer but I did. Awesome advice. Cheers! \$\endgroup\$Kaz– Kaz2015年12月22日 17:54:47 +00:00Commented 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\$Kaz– Kaz2015年12月22日 17:59:30 +00:00Commented 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\$Kaz– Kaz2015年12月22日 18:07:07 +00:00Commented 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\$Dirk Reichel– Dirk Reichel2015年12月22日 18:22:23 +00:00Commented Dec 22, 2015 at 18:22
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.