This Macro takes my company's 2 main sources of all-client data (each a data table in a separate worksheet) and aggregates them into a 3rd list, by matching a unique account number (for clients that have an account number).As always, I'm welcome to all feedback on any aspect of the Code and in particular, I'm interested in:Readability: Ability for somebody who is not me to come in blind, and (relatively) easily figure out how the whole thing works and fixsome 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.Workbook download if desiredN.B. As this is for internal consumption, I've designed the macro to take any size of data in any order, so long as the required Column Headings are present.Module 1: Combine_ACT_Ascentric_Data - All Macros unique to this projectOption ExplicitOption Compare TextPublic wbCurrent As WorkbookPublic wsAscentric     As WorksheetPublic wsAct           As WorksheetPublic wsCombinedList  As WorksheetPublic arrCombinedData  As VariantPublic lngCurrentRow    As VariantPublic arrActData       As VariantPublic arrAscentricData As VariantPublic colAscentricHeadings    As Collection '/ Required Headings in the respective Data SetsPublic colActHeadings          As Collection '/Public Sub CombineACTandAscentricData()    Call StoreApplicationSettings    Call DisableApplicationSettings    '/======================================================================================================================================================    '/  Author:  Zak Armstrong    '/  Email:   zak.armstrong@luminwealth.co.uk    '/  Date:    25/August/2015    '/    '/  Description:    Given the All Client Wrappers Data table from Ascentric and an Excel Export of ACT Client data, assign the desired data from ACT to the Ascentric    '/                  Data and print to a 3rd Workshet. Clients details are matched by matching the ascentric account number in each data set    '/                  (Account No in Ascentric, Ascentric Plan No in ACT).    '/======================================================================================================================================================    Dim i As Long, j As Long, k As Long    Dim strErrorMessage As String    '/======================================================================================================================================================            Set wbCurrent = ThisWorkbook            Call AssignWorksheets            Call FillCollections        '/==================================================        '/  Get Sheet Data into arrays, assign array bounds        '/==================================================        Dim lngActFinalRow          As Long        Dim lngActFinalcolumn       As Long        Dim lngAscentricFinalRow    As Long        Dim lngAscentricFinalcolumn As Long        Dim strTopLeftCell As String        arrAscentricData = Array()        arrActData = Array()            Call PutSheetDataInArray(wbCurrent, wsAscentric, arrAscentricData)            Call PutSheetDataInArray(wbCurrent, wsAct, arrActData)            Call AssignArrayBounds(arrAscentricData, UB1:=lngAscentricFinalRow, UB2:=lngAscentricFinalcolumn)            Call AssignArrayBounds(arrActData, UB1:=lngActFinalRow, UB2:=lngActFinalcolumn)        '/==================================================        '/  Check For Required Columns        '/==================================================            Call CheckForHeadings(colActHeadings, arrActData)            Call CheckForHeadings(colAscentricHeadings, arrAscentricData)        '/==================================================        '/  Find Account Number Columns        '/==================================================        Dim lngAscentricAccountColumn   As Long        Dim lngActAccountColumn         As Long            For i = 1 To lngAscentricFinalcolumn                If arrAscentricData(1, i) = Account No Then lngAscentricAccountColumn = i            Next i            For i = 1 To lngActFinalcolumn                If arrActData(1, i) = Ascentric Plan No Then lngActAccountColumn = i            Next i            strErrorMessage = Couldn't Find Account Column:             If lngAscentricAccountColumn = 0 Then Call ErrorMessage(strErrorMessage & Account No - Ascentric)            If lngAscentricAccountColumn = 0 Then Call ErrorMessage(strErrorMessage & Ascentric Plan No - Act)        '/==================================================        '/  Prepare arrCombined Data        '/==================================================        arrCombinedData = Array()            lngCurrentRow = 1            ReDim arrCombinedData(1 To lngActFinalcolumn + lngAscentricFinalcolumn, 1 To lngCurrentRow)            For i = 1 To lngAscentricFinalcolumn                arrCombinedData(i, 1) = arrAscentricData(1, i)            Next i            For i = 1 To lngActFinalcolumn                arrCombinedData(i + lngAscentricFinalcolumn, 1) = arrActData(1, i)            Next i        '/==================================================        '/  Match Lists        '/==================================================            Call MatchLists(lngAscentricAccountColumn, lngActAccountColumn)        '/==================================================        '/  Print Data        '/==================================================        Dim rngTopLeftCell As Range            wsCombinedList.Activate            wsCombinedList.Cells.Clear            Call Transpose2dArray(arrCombinedData)            Set rngTopLeftCell = wsCombinedList.Cells(1, 1)            Call Print2dArrayToSheet(wbCurrent, wsCombinedList, arrCombinedData, rngTopLeftCell)            Columns.AutoFit        Call RestoreApplicationSettingsEnd SubPrivate Sub AssignWorksheets()    Set wsAscentric = Worksheets(Ascentric Wrapper Data)    Set wsAct = Worksheets(ACT! Data)    Set wsCombinedList = Worksheets(Combined List)End SubPrivate Sub FillCollections()    Set colAscentricHeadings = New Collection    colAscentricHeadings.Add (Account No)    colAscentricHeadings.Add (Account Title)    colAscentricHeadings.Add (Wrapper)    colAscentricHeadings.Add (Attached To Model)    colAscentricHeadings.Add (Advised By)    Set colActHeadings = New Collection    colActHeadings.Add (First Name)    colActHeadings.Add (Last Name)    colActHeadings.Add (Annual Review)    colActHeadings.Add (E-mail)    colActHeadings.Add (Ascentric Plan No)End SubPrivate Sub CheckForHeadings(ByRef colHeadings As Collection, ByRef arrData As Variant)    Dim LB2 As Long    Dim UB2 As Long    Dim i As Long, j As Long, k As Long    Dim varHolder As Variant    Dim strErrorMessage As String    Dim bHeadingFound        As Boolean    Dim bAllHeadingsFound    As Boolean        Call AssignArrayBounds(arrData, LB2:=LB2, UB2:=UB2)        bAllHeadingsFound = True                For i = 1 To colHeadings.Count                    bHeadingFound = False                    For j = LB2 To UB2                        varHolder = arrData(1, j)                        If varHolder = colHeadings(i) Then bHeadingFound = True                    Next j                    If bHeadingFound = False Then bAllHeadingsFound = False                Next i            If bAllHeadingsFound = False _                Then                    strErrorMessage = Unexpected Column Heading:  & arrData(0, 0)                    Call ErrorMessage(strErrorMessage)            End IfEnd SubPrivate Sub MatchLists(ByVal lngAscentricAccountColumn As Long, ByVal lngActAccountColumn As Long)    Dim i As Long, j As Long, k As Long    Dim lngActFinalRow          As Long    Dim lngActFinalcolumn       As Long    Dim lngAscentricFinalRow    As Long    Dim lngAscentricFinalcolumn As Long        Call AssignArrayBounds(arrAscentricData, UB1:=lngAscentricFinalRow, UB2:=lngAscentricFinalcolumn)        Call AssignArrayBounds(arrActData, UB1:=lngActFinalRow, UB2:=lngActFinalcolumn)    Dim lngAccountNumberAscentric   As Long    Dim lngAccountNumberAct         As Long    Dim varHolder As Variant    Dim bMatchFound As Boolean        For i = 2 To lngAscentricFinalRow            lngAccountNumberAscentric = arrAscentricData(i, lngAscentricAccountColumn)            '/ Check For Match                bMatchFound = False                j = 1                Do While bMatchFound = False And j < lngActFinalRow                    j = j + 1                    varHolder = arrActData(j, lngActAccountColumn)                    If IsNumeric(varHolder) Then lngAccountNumberAct = varHolder Else lngAccountNumberAct = 0                    bMatchFound = (lngAccountNumberAscentric = lngAccountNumberAct)                Loop            '/ Copy to arrCombinedData                lngCurrentRow = lngCurrentRow + 1                ReDim Preserve arrCombinedData(1 To UBound(arrCombinedData, 1), 1 To lngCurrentRow)                For k = 1 To lngAscentricFinalcolumn                    arrCombinedData(k, lngCurrentRow) = arrAscentricData(i, k)                Next k                If bMatchFound _                    Then                        For k = 1 To lngActFinalcolumn                            arrCombinedData(k + lngAscentricFinalcolumn, lngCurrentRow) = arrActData(j, k)                        Next k                End If        Next iEnd SubModule 2: Standard_Subs_FunctionsOption ExplicitOption Compare TextPublic Const LngFinalCellRow     As Long = 1048576Public Const LngFinalCellColumn  As Long = 16384Public varScreenUpdating    As VariantPublic varEnableEvents      As VariantPublic varCalculation       As VariantPublic Function IsWorkbookOpen(ByVal strTargetName As String) As Boolean    On Error Resume Next        Workbooks(strTargetName).Activate        IsWorkbookOpen = (ActiveWorkbook.Name = strTargetName)    On Error GoTo 0End FunctionPublic Sub PutSheetDataInArray(ByRef wbCurrentWorkbook As Workbook, ByRef wsCurrentWorksheet As Worksheet, ByRef arrCurrentArray As Variant, Optional ByVal strTopLeftCellIdentifier As Variant, _Optional ByVal lngStartRow As Long = 1, Optional ByVal lngEndRow As Long = 10, _Optional ByVal lngStartColumn As Long = 1, Optional ByVal lngEndColumn As Long = 10)    '/======================================================================================================================================================    '/  Author:  Zak Armstrong    '/  Email:   zak.armstrong@luminwealth.co.uk    '/  Date:    21/August/2015    '/    '/  Note:   if strTopLeftCellIdentifer not supplied, assumes (1,1) is the start of the data.    '/======================================================================================================================================================    Dim i                                           As Long    Dim j                                           As Long    Dim k                                           As Long    Dim lngFirstRow                                 As Long    Dim lngFirstColumn                              As Long    Dim lngFinalRow                                 As Long    Dim lngFinalColumn                              As Long    Dim rngTopLeftCell                              As Range    Dim rngSearchRange                              As Range    Dim strErrorMessage                             As String    '/======================================================================================================================================================        '/==================================================        '/ Open Worksheet        '/==================================================            wbCurrentWorkbook.Activate            wsCurrentWorksheet.Activate            wsCurrentWorksheet.Cells.EntireRow.Hidden = False        '/==================================================        '/ Find TopLeftCell        '/==================================================            If IsMissing(strTopLeftCellIdentifier) _                Then                    Set rngTopLeftCell = Cells(1, 1)                ElseIf TypeName(strTopLeftCellIdentifier) = vbString _                    Then                        If IsMissing(lngEndRow) Then lngEndRow = wsCurrentWorksheet.Rows.Count                        If IsMissing(lngEndColumn) Then lngEndColumn = wsCurrentWorksheet.Columns.Count                            Set rngSearchRange = wsCurrentWorksheet.Range(Cells(lngStartRow, lngStartColumn), Cells(lngEndRow, lngEndColumn))                            Call FindStringInRange(rngSearchRange, rngTopLeftCell, strTopLeftCellIdentifier)                    Else                        strErrorMessage = strTopLeftCellIdentifier must be a string, not a  & TypeName(strTopLeftCellIdentifier)                        Call ErrorMessage(strErrorMessage)            End If        '/==================================================        '/ Determine range of data, pass to array        '/==================================================            lngFirstRow = rngTopLeftCell.Row            lngFirstColumn = rngTopLeftCell.Column            lngFinalRow = Cells(LngFinalCellRow, lngFirstColumn).End(xlUp).Row            lngFinalColumn = Cells(lngFirstRow, LngFinalCellColumn).End(xlToLeft).Column            ReDim arrCurrentArray(0 To lngFinalRow - lngFirstRow + 1, 0 To lngFinalColumn - lngFirstColumn + 1)            arrCurrentArray(0, 0) = wsCurrentWorksheet.Name            For i = lngFirstRow To lngFinalRow                For j = lngFirstColumn To lngFinalColumn                    arrCurrentArray(i - lngFirstRow + 1, j - lngFirstColumn + 1) = wsCurrentWorksheet.Cells(i, j)                Next j            Next iEnd SubPublic 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        Call AssignArrayBounds(arrSource, LB1, UB1, LB2, UB2, LB3, UB3, LB4, UB4, LB5, UB5)        Erase arrDestination        ReDim arrDestination(LB1 To UB1, LB2 To UB2, LB3 To UB3, LB4 To UB4, LB5 To UB5)        For i = LB1 To UB1        For j = LB2 To UB2        For k = LB3 To UB3        For l = LB4 To UB4        For m = LB5 To UB5            arrDestination(i, j, k, l, m) = arrSource(i, j, k, l, m)        Next m        Next l        Next k        Next j        Next iEnd SubPublic 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        Call AssignArrayBounds(arrSource, LB1, UB1, LB2, UB2, LB3, UB3, LB4, UB4)        Erase arrDestination        ReDim arrDestination(LB1 To UB1, LB2 To UB2, LB3 To UB3, LB4 To UB4)        For i = LB1 To UB1        For j = LB2 To UB2        For k = LB3 To UB3        For l = LB4 To UB4            arrDestination(i, j, k, l) = arrSource(i, j, k, l)        Next l        Next k        Next j        Next iEnd SubPublic 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        Call AssignArrayBounds(arrSource, LB1, UB1, LB2, UB2, LB3, UB3)        Erase arrDestination        ReDim arrDestination(LB1 To UB1, LB2 To UB2, LB3 To UB3)        For i = LB1 To UB1        For j = LB2 To UB2        For k = LB3 To UB3            arrDestination(i, j, k) = arrSource(i, j, k)        Next k        Next j        Next iEnd SubPublic 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        Call AssignArrayBounds(arrSource, LB1, UB1, LB2, UB2)        Erase arrDestination        ReDim arrDestination(LB1 To UB1, LB2 To UB2)        For i = LB1 To UB1        For j = LB2 To UB2            arrDestination(i, j) = arrSource(i, j)        Next j        Next iEnd SubPublic Sub CopyArrayContents1d(ByRef arrSource As Variant, ByRef arrDestination As Variant)    Dim LB1 As Long, UB1 As Long    Dim i As Long        Call AssignArrayBounds(arrSource, LB1, UB1)        Erase arrDestination        ReDim arrDestination(LB1 To UB1)        For i = LB1 To UB1            arrDestination(i) = arrSource(i)        Next iEnd SubPublic 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 SubPublic Sub ErrorMessage(ByVal strErrorMessage As String)    MsgBox strErrorMessage    Debug.Print strErrorMessage    Call RestoreApplicationSettings(varScreenUpdating, varEnableEvents, varCalculation)    EndEnd SubPublic 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        Call AssignArrayBounds(arrCurrentArray, LB1, UB1, LB2, UB2)        Dim arrTransposedArray() As Variant        ReDim arrTransposedArray(LB2 To UB2, LB1 To UB1)        For i = LB1 To UB1        For j = LB2 To UB2            arrTransposedArray(j, i) = arrCurrentArray(i, j)        Next j        Next i        Erase arrCurrentArray        ReDim arrCurrentArray(LB2 To UB2, LB1 To UB1)        Call CopyArrayContents2d(arrTransposedArray, arrCurrentArray)End SubPublic Sub StoreApplicationSettings()    varScreenUpdating = Application.ScreenUpdating    varEnableEvents = Application.EnableEvents    varCalculation = Application.CalculationEnd SubPublic Sub DisableApplicationSettings()    Application.ScreenUpdating = False    Application.EnableEvents = False    Application.Calculation = xlCalculationManualEnd SubPublic Sub RestoreApplicationSettings()    Application.ScreenUpdating = varScreenUpdating    Application.EnableEvents = varEnableEvents    Application.Calculation = varCalculationEnd SubPublic Sub GetWorkbook(ByVal strFilename As String, ByVal strFilePath As String)    Dim bIsWbOpen As Boolean    bIsWbOpen = IsWorkbookOpen(strFilename)    If bIsWbOpen = False Then Workbooks.Open strFilePath & strFilenameEnd SubPublic Sub Print2dArrayToSheet(ByRef wbTarget As Workbook, ByRef wsTarget As Worksheet, ByRef arrData As Variant, ByRef rngStartCell As Range)    Dim LB1 As Long    Dim UB1 As Long    Dim LB2 As Long    Dim UB2 As Long    Dim rngTableRange As Range        wbTarget.Activate        wsTarget.Activate        Call AssignArrayBounds(arrData, LB1, UB1, LB2, UB2)        Set rngTableRange = Range(rngStartCell, Cells(rngStartCell.Row + UB1 - LB1, rngStartCell.Column + UB2 - LB2))        rngTableRange = arrDataEnd SubPublic Sub CopyArrayColumn2d(ByRef arrCurrentArray As Variant, ByRef arrDestination As Variant, ByVal lngSourcePosition As Long, ByVal lngDestinationPosition As Long)    Dim i As Long        For i = LBound(arrCurrentArray) To UBound(arrCurrentArray)            arrDestination(i, lngDestinationPosition) = arrCurrentArray(i, lngSourcePosition)        Next iEnd SubPublic Sub FindStringInRange(ByRef rngSearch As Range, ByRef rngFoundCell As Range, ByVal strSearch As String)    Dim strErrorMessage As String        Set rngFoundCell = rngSearch.Find(strSearch, LookIn:=xlValues)        If rngFoundCell Is Nothing _            Then                strErrorMessage = Couldn't find cell  & strSearch &  in  & rngSearch.Worksheet.Name                Call ErrorMessage(strErrorMessage)        End IfEnd Sub
Aggregating 2 lists by matching UniqueIDs
vba;excel;join
Here are a couple of points about your standard subs & functions:I've mentioned in another post that IsWorkbookOpen has a side-affect of activating the workbook.At first glance the FindStringInRange doesn't seem to do anything, it's a sub, but then you realise that it changes the ByRef rngFoundCell  Range variable. I think this should be a function which returns a Range object rather than altering a parameter. Much easier to see what is happening.You are using variants for the application settings but why not use a boolean or the actual enum definition. That way you get intelli-sense help.Public blnScreenUpdating    As BooleanPublic blnEnableEvents      As BooleanPublic varCalculation       As xlCalculationIn some places you have code that says something like If bBookIsOpen = False Then. Consider whether If Not bBookIsOpen Then is easier to understand. The naming of the variable makes a lot of difference here.You've got several procs CopyArrayContentsXd that do a lot of similar things. Maybe consider merging this into a generic proc that takes a parameter for numDimensions or works it out from the array.In PutSheetDataInArray you've got several Optional parameters with a default value of 10 (Why 10? Why not just leave empty?) However, you then use the IsMissing function on all of these parameters. On first glance, this makes no sense because how can a variable be missing if you've given it a default value? Looking at the help for the IsMissing function further reveals that it only works on Variants as well. You need to re-work this proc.If you are using lots of arrays/collections and then testing if a value exists, consider whether a dictionary is a better choice.That's all for now.