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 DocsAdviser Submission Reports"               '/  The path of the folder containing the Adviser Report
Public Const StrSavedReportsFilePath                As String = "S:Lumin Admin DocsAdviser Submission ReportsSaved Reports" '/  The path of the folder containing previous reports
Public Const StrSubsheetFilePath                    As String = "S:Lumin Admin DocsSubsheet 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

Public Sub GenerateAdviserSubmissionReports()

    StoreApplicationSettings

    DisableApplicationSettings

    '/======================================================================================================================================================
    '/  Author:  Zak Armstrong
    '/  Email:   zak.armstrong@luminwealth.co.uk
    '/  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

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

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

Private Sub GetAllSheetDataIntoArrays()

    '/======================================================================================================================================================
    '/  Author:  Zak Armstrong
    '/  Email:   zak.armstrong@luminwealth.co.uk
    '/  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

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

Private Sub FilterSheetArrayForColumns(ByRef arrSource As Variant)

    '/======================================================================================================================================================
    '/  Author:  Zak Armstrong
    '/  Email:   zak.armstrong@luminwealth.co.uk
    '/  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

Public Sub MissingDataHeadingsHandler(ByRef arrCurrentArray As Variant, ByVal strHeading As String)

    '/======================================================================================================================================================
    '/  Author:  Zak Armstrong
    '/  Email:   zak.armstrong@luminwealth.co.uk
    '/  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

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

Private Sub AggregateSheetData()

    '/======================================================================================================================================================
    '/  Author:  Zak Armstrong
    '/  Email:   zak.armstrong@luminwealth.co.uk
    '/  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

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

Private Sub CleanUpAggregatedData()

    '/======================================================================================================================================================
    '/  Author:  Zak Armstrong
    '/  Email:   zak.armstrong@luminwealth.co.uk
    '/  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

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

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

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

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

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