10
\$\begingroup\$

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 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.

Workbook download if desired

N.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 project

Option Explicit
Option Compare Text

Public wbCurrent As Workbook

Public wsAscentric     As Worksheet
Public wsAct           As Worksheet
Public wsCombinedList  As Worksheet

Public arrCombinedData  As Variant
Public lngCurrentRow    As Variant

Public arrActData       As Variant
Public arrAscentricData As Variant

Public colAscentricHeadings    As Collection '/ Required Headings in the respective Data Sets
Public colActHeadings          As Collection '/


Public Sub CombineACTandAscentricData()

    Call StoreApplicationSettings
    Call DisableApplicationSettings

    '/======================================================================================================================================================
    '/  Author:  Zak Armstrong
    '/  Email:   [email protected]
    '/  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 RestoreApplicationSettings

End Sub

Private Sub AssignWorksheets()

    Set wsAscentric = Worksheets("Ascentric Wrapper Data")
    Set wsAct = Worksheets("ACT! Data")
    Set wsCombinedList = Worksheets("Combined List")

End Sub

Private 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 Sub

Private 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 If

End Sub

Private 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 i

End Sub

Module 2: "Standard_Subs_Functions"

Option Explicit
Option Compare Text

Public Const LngFinalCellRow     As Long = 1048576
Public Const LngFinalCellColumn  As Long = 16384

Public varScreenUpdating    As Variant
Public varEnableEvents      As Variant
Public varCalculation       As Variant

Public Function IsWorkbookOpen(ByVal strTargetName As String) As Boolean

    On Error Resume Next

        Workbooks(strTargetName).Activate

        IsWorkbookOpen = (ActiveWorkbook.Name = strTargetName)

    On Error GoTo 0

End Function

Public 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:   [email protected]
    '/  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 i
End Sub

Public Sub CopyArrayContents5d(ByRef arrSource As Variant, ByRef arrDestination As Variant)

    Dim LB1 As Long, UB1 As Long
    Dim LB2 As Long, UB2 As Long
    Dim LB3 As Long, UB3 As Long
    Dim LB4 As Long, UB4 As Long
    Dim LB5 As Long, UB5 As Long

    Dim i As Long, 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 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

        Call AssignArrayBounds(arrSource, LB1, UB1, LB2, UB2, LB3, UB3, LB4, UB4)

        Erase arrDestination
        ReDim arrDestination(LB1 To UB1, LB2 To UB2, LB3 To UB3, LB4 To UB4)

        For i = LB1 To UB1
        For j = LB2 To UB2
        For k = LB3 To UB3
        For l = LB4 To UB4
            arrDestination(i, j, k, l) = arrSource(i, j, k, l)
        Next l
        Next k
        Next j
        Next i

End Sub

Public Sub CopyArrayContents3d(ByRef arrSource As Variant, ByRef arrDestination As Variant)

    Dim LB1 As Long, UB1 As Long
    Dim LB2 As Long, UB2 As Long
    Dim LB3 As Long, UB3 As Long

    Dim i As Long, 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 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

        Call AssignArrayBounds(arrSource, LB1, UB1, LB2, UB2)

        Erase arrDestination
        ReDim arrDestination(LB1 To UB1, LB2 To UB2)

        For i = LB1 To UB1
        For j = LB2 To UB2
            arrDestination(i, j) = arrSource(i, j)
        Next j
        Next i

End Sub

Public Sub CopyArrayContents1d(ByRef arrSource As Variant, ByRef arrDestination As Variant)

    Dim LB1 As Long, UB1 As Long

    Dim i As Long

        Call AssignArrayBounds(arrSource, LB1, UB1)

        Erase arrDestination
        ReDim arrDestination(LB1 To UB1)

        For i = LB1 To UB1
            arrDestination(i) = arrSource(i)
        Next i

End Sub

Public Sub AssignArrayBounds(ByRef arrCurrentArray As Variant, _
                                Optional ByRef LB1 As Variant, Optional ByRef UB1 As Variant, _
                                Optional ByRef LB2 As Variant, Optional ByRef UB2 As Variant, _
                                Optional ByRef LB3 As Variant, Optional ByRef UB3 As Variant, _
                                Optional ByRef LB4 As Variant, Optional ByRef UB4 As Variant, _
                                Optional ByRef LB5 As Variant, Optional ByRef UB5 As Variant)

    If Not IsMissing(LB1) Then LB1 = LBound(arrCurrentArray, 1)
    If Not IsMissing(UB1) Then UB1 = UBound(arrCurrentArray, 1)
    If Not IsMissing(LB2) Then LB2 = LBound(arrCurrentArray, 2)
    If Not IsMissing(UB2) Then UB2 = UBound(arrCurrentArray, 2)
    If Not IsMissing(LB3) Then LB3 = LBound(arrCurrentArray, 3)
    If Not IsMissing(UB3) Then UB3 = UBound(arrCurrentArray, 3)
    If Not IsMissing(LB4) Then LB4 = LBound(arrCurrentArray, 4)
    If Not IsMissing(UB4) Then UB4 = UBound(arrCurrentArray, 4)
    If Not IsMissing(LB5) Then LB5 = LBound(arrCurrentArray, 5)
    If Not IsMissing(UB5) Then UB5 = UBound(arrCurrentArray, 5)

End Sub

Public Sub ErrorMessage(ByVal strErrorMessage As String)

    MsgBox strErrorMessage
    Debug.Print strErrorMessage
    Call RestoreApplicationSettings(varScreenUpdating, varEnableEvents, varCalculation)
    End

End Sub

Public Sub Transpose2dArray(ByRef arrCurrentArray As Variant)

    Dim LB1 As Long, UB1 As Long
    Dim LB2 As Long, UB2 As Long

    Dim i As Long, j As Long

        Call AssignArrayBounds(arrCurrentArray, LB1, UB1, LB2, UB2)

        Dim arrTransposedArray() As Variant
        ReDim arrTransposedArray(LB2 To UB2, LB1 To UB1)

        For i = LB1 To UB1
        For j = LB2 To UB2
            arrTransposedArray(j, i) = arrCurrentArray(i, j)
        Next j
        Next i

        Erase arrCurrentArray
        ReDim arrCurrentArray(LB2 To UB2, LB1 To UB1)
        Call CopyArrayContents2d(arrTransposedArray, arrCurrentArray)

End Sub

Public Sub StoreApplicationSettings()

    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 GetWorkbook(ByVal strFilename As String, ByVal strFilePath As String)

    Dim bIsWbOpen As Boolean

    bIsWbOpen = IsWorkbookOpen(strFilename)
    If bIsWbOpen = False Then Workbooks.Open strFilePath & strFilename

End Sub

Public Sub Print2dArrayToSheet(ByRef wbTarget As Workbook, ByRef wsTarget As Worksheet, ByRef arrData As Variant, ByRef rngStartCell As Range)

    Dim LB1 As Long
    Dim UB1 As Long
    Dim LB2 As Long
    Dim UB2 As Long

    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 = arrData

End Sub

Public 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 i

End Sub

Public 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 If

End Sub
\$\endgroup\$
2
  • \$\begingroup\$ Is ACTDATA - Ascentric Plan no what should match to Ascentric Wrapper Data - Account No? \$\endgroup\$ Aug 26, 2015 at 11:17
  • \$\begingroup\$ Yes. they both refer to unique Ascentric Account Numbers. Under the heading "Account No" in the ascentric data, and "Ascentric Plan No" in the Act data. \$\endgroup\$
    – Kaz
    Aug 26, 2015 at 11:19

1 Answer 1

5
\$\begingroup\$

Here are a couple of points about your standard subs & functions:

  1. I've mentioned in another post that IsWorkbookOpen has a side-affect of activating the workbook.
  2. 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.
  3. 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 Boolean
    Public blnEnableEvents      As Boolean
    Public varCalculation       As xlCalculation
    
  4. In 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.

  5. 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.

  6. 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.

  7. 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.

\$\endgroup\$
0

Your Answer

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

Not the answer you're looking for? Browse other questions tagged or ask your own question.