Option Explicit

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

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

'/ 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 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.3.xlsm"                        '/  The filename of the Adviser Submissions Report
Public Const StrSubsheetFilename                    As String = "Lumin Subsheet 2015.xlsm"                                      '/  The filename of the Subsheet

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

Option Explicit
Option Compare Text

Public Sub GenerateAdviserSubmissionReports()

    Dim varScreenUpdating As Variant
    Dim varEnableEvents As Variant
    Dim varCalculation As Variant

    Call StoreApplicationSettings(varScreenUpdating, varEnableEvents, varCalculation)
    Call 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)
    '/======================================================================================================================================================
    Dim arrNewClient                        As Variant      '/  all data on the "New Client Investment" Sheet
        arrNewClient = Array()

    Dim arrExistingClient                   As Variant      '/  all data on the "Existing Client Investment" Sheet
        arrExistingClient = Array()

    Dim arrGroupSchemes                     As Variant      '/  all data on the "Group Schemes" Sheet
        arrGroupSchemes = Array()

    Dim arrOther                            As Variant      '/  all data on the "Other" Sheet
        arrOther = Array()

    Dim arrMcOngoing                        As Variant      '/  all data on the "MC Ongoing" Sheet
        arrMcOngoing = Array()

    Dim arrJhOngoing                        As Variant      '/  all data on the "JH Ongoing" Sheet
        arrJhOngoing = Array()

    Dim arrAegonQuilterArc                  As Variant      '/  all data on the "AG-QU-ARC" Sheet
        arrAegonQuilterArc = Array()

    Dim arrAscentric                        As Variant      '/  all data on the "Ascentric" Sheet
        arrAscentric = Array()

    Dim i                                   As Long         '/  General counters
    Dim j                                   As Long         '/
    Dim k                                   As Long         '/
    '/======================================================================================================================================================
            Call InitialiseStuff

        '/==================================================
        '/ Get all sheet data into arrays
        '/==================================================

            Dim strTopLeftCellIdentifier    As String
                strTopLeftCellIdentifier = "Adviser"

                Call PutSheetDataInArray(WbSubsheet, WsNewClient, arrNewClient, strTopLeftCellIdentifier)
                Call PutSheetDataInArray(WbSubsheet, WsExistingClient, arrExistingClient, strTopLeftCellIdentifier)
                Call PutSheetDataInArray(WbSubsheet, WsGroupSchemes, arrGroupSchemes, strTopLeftCellIdentifier)
                Call PutSheetDataInArray(WbSubsheet, WsOther, arrOther, strTopLeftCellIdentifier)
                Call PutSheetDataInArray(WbSubsheet, WsMcOngoing, arrMcOngoing, strTopLeftCellIdentifier)
                Call PutSheetDataInArray(WbSubsheet, WsJhOngoing, arrJhOngoing, strTopLeftCellIdentifier)
                Call PutSheetDataInArray(WbSubsheet, WsAegonQuilterArc, arrAegonQuilterArc, strTopLeftCellIdentifier)

                strTopLeftCellIdentifier = "Account No"
                Call PutSheetDataInArray(WbSubsheet, WsAscentric, arrAscentric, strTopLeftCellIdentifier)

                Call 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

        '/==================================================
        '/ Filter sheet data for desired columns
        '/==================================================
            For i = LBound(ArrAggregatedArrays) To UBound(ArrAggregatedArrays)
                Call FilterSheetArrayForColumns(ArrAggregatedArrays(i))
            Next i

        '/==================================================
        '/ Aggregate Data
        '/==================================================
            Call AggregateSheetData

                Application.DisplayAlerts = False
                WbSubsheet.Close
                Application.DisplayAlerts = True

        '/==================================================
        '/ Print Data
        '/==================================================

            Dim rngStartCell As Range
            Set rngStartCell = WsAggregatedData.Cells(1, 1)

            Call Print2dArrayToSheet(WbAdviserReport, WsAggregatedData, ArrAggregatedData, rngStartCell)

    Call RestoreApplicationSettings(varScreenUpdating, varEnableEvents, varCalculation)

End Sub

Public Sub FilterSheetArrayForColumns(ByRef arrCurrentArray 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
    Dim j                                           As Long
    Dim k                                           As Long

    Dim lngFinalRow                                 As Long
    Dim lngFinalColumn                              As Long

    Dim arrTempArray                                As Variant      '/  Temporarily holds the filtered information
        arrTempArray = Array()

    Dim arrHeadingsRow                              As Variant      '/  Holds the top (headings) row for application.match
        arrHeadingsRow = Array()

    Dim varColumnPosition                           As Variant      '/  Holds the position of the relevant column

    Dim strHeading                                  As String       '/  The current heading to search for
    '/======================================================================================================================================================

    Call AssignArrayBounds(arrCurrentArray:=arrCurrentArray, UB1:=lngFinalRow, UB2:=lngFinalColumn)

        '/==================================================
        '/ Recreate Headings Row
        '/==================================================
            ReDim arrHeadingsRow(1 To lngFinalColumn)

                For i = 1 To lngFinalColumn
                    arrHeadingsRow(i) = arrCurrentArray(1, i)
                Next i

        '/==================================================
        '/ Find Columns, put in array
        '/==================================================
            ReDim arrTempArray(0 To lngFinalRow, 0 To ColAllHeadings.Count)
            arrTempArray(0, 0) = arrCurrentArray(0, 0)

            Dim lngDestinationColumn As Long
            Dim lngSourceColumn As Long

                For i = 1 To ColAllHeadings.Count
                    strHeading = ColAllHeadings(i)
                    varColumnPosition = Application.Match(strHeading, arrHeadingsRow, 0)

                        If IsError(varColumnPosition) _
                            Then
                                Call MissingDataHeadingsHandler(arrCurrentArray, strHeading)
                            Else
                                lngDestinationColumn = i
                                lngSourceColumn = varColumnPosition

                                Call CopyColumn2d(arrCurrentArray, arrTempArray, lngSourceColumn, lngDestinationColumn)
                        End If
                Next i

        Call CopyArrayContents2d(arrTempArray, arrCurrentArray)

End Sub

Public 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 rngTopLeftCell          As Range

    Dim lngFirstRow             As Long
    Dim lngFirstColumn          As Long

    Dim lngCurrentRow           As Long

    Dim lngFinalRow             As Long
    Dim lngFinalColumn          As Long

    Dim i As Long
    Dim j As Long
    Dim k As Long

    Dim rngTableRange           As Range

    Dim arrTransposedData()     As Variant

    Dim strHolder               As String

    Dim LB1 As Long
    Dim UB1 As Long
    Dim LB2 As Long
    Dim UB2 As Long
    '/======================================================================================================================================================

        '/==================================================
        '/ Aggregate Data
        '/==================================================

        lngCurrentRow = 1
        ReDim ArrAggregatedData(1 To ColAllHeadings.Count, 1 To 1)

        For i = 1 To ColAllHeadings.Count
            ArrAggregatedData(i, 1) = ColAllHeadings(i)
        Next i

            For i = LBound(ArrAggregatedArrays) To UBound(ArrAggregatedArrays)

                Call 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

        '/==================================================
        '/ Transpose Data
        '/==================================================
            Call Transpose2dArray(ArrAggregatedData)

        '/==================================================
        '/ Print to sheet
        '/==================================================
            Call Print2dArrayToSheet(wbTarget, wsTarget, arrData, rngStartCell)

End Sub

Option Explicit
Option Compare Text

Public Sub InitialiseStuff()

            '/ initialise public arrays
            ArrAggregatedData = Array()
            ArrAggregatedArrays = Array()
            ArrProviders = Array()
            ArrAdvisers = Array()

            Call GetWorkbook(StrAdviserReportFilename, StrAdviserReportFilePath)
            Set WbAdviserReport = Workbooks(StrAdviserReportFilename)

            Call GetWorkbook(StrSubsheetFilename, StrSubsheetFilePath)
            Set WbSubsheet = Workbooks(StrSubsheetFilename)

            Call AssignWorksheets

            Call InitialiseCollections

End Sub

Public Sub InsertAscentricLifeCoColumn(ByRef arrAscentric As Variant)

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

    Call 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



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
                    Call InitialiseNewClientHeadingsExceptions(colMissingSheetHeadings)

                Case Is = WsExistingClient.Name
                    Call InitialiseExistingClientHeadingsExceptions(colMissingSheetHeadings)


                Case Is = WsGroupSchemes.Name
                    Call InitialiseGroupSchemesHeadingsExceptions(colMissingSheetHeadings)


                Case Is = WsOther.Name
                    Call InitialiseOtherHeadingsExceptions(colMissingSheetHeadings)


                Case Is = WsMcOngoing.Name
                    Call InitialiseMcOngoingHeadingsExceptions(colMissingSheetHeadings)


                Case Is = WsJhOngoing.Name
                    Call InitialiseJhOngoingHeadingsExceptions(colMissingSheetHeadings)


                Case Is = WsAegonQuilterArc.Name
                    Call InitialiseAegonQuilterArcHeadingsExceptions(colMissingSheetHeadings)


                Case Is = WsAscentric.Name
                    Call InitialiseAscentricHeadingsExceptions(colMissingSheetHeadings)

                Case Else
                    Call 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 Call ErrorMessage(strErrorMessage)

End Sub

Option Explicit
Option Compare Text

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")

        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) & "/" & Year(Date)))
            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")

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

Public Sub InitialiseExistingClientHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)

'/ Different List of names

End Sub

Public Sub InitialiseGroupSchemesHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)

'/ Different List of names

End Sub

Public Sub InitialiseOtherHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)

'/ Different List of names

End Sub

Public Sub InitialiseMcOngoingHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)

'/ Different List of names

End Sub

Public Sub InitialiseJhOngoingHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)

'/ Different List of names

End Sub

Public Sub InitialiseAegonQuilterArcHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)

'/ Different List of names

End Sub

Public Sub InitialiseAscentricHeadingsExceptions(ByRef colMissingSheetHeadings As Collection)

'/ Different List of names
End Sub

Option Explicit
Option Compare Text

Public Function IsWorkbookOpen(ByVal strTargetName As String) As Boolean

    On Error Resume Next

        Workbooks(strTargetName).Activate

        If ActiveWorkbook.Name <> strTargetName _
            Then
                IsWorkbookOpen = False
            Else
                IsWorkbookOpen = True
        End If

    On Error GoTo 0

End Function

Public Sub PutSheetDataInArray(ByRef wbCurrentWorkbook As Workbook, ByRef wsCurrentWorksheet As Worksheet, ByRef arrCurrentArray As Variant, ByVal strTopLeftCellIdentifier As String, _
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
    '/======================================================================================================================================================
    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(lngEndRow) Then lngEndRow = wsCurrentWorksheet.Rows.Count
            If IsMissing(lngEndColumn) Then lngEndColumn = wsCurrentWorksheet.Columns.Count

                Set rngSearchRange = wsCurrentWorksheet.Range(Cells(lngStartRow, lngStartColumn), Cells(lngEndRow, lngEndColumn))
                    Set rngTopLeftCell = rngSearchRange.Find(strTopLeftCellIdentifier, LookIn:=xlValues)

                    If rngTopLeftCell Is Nothing _
                        Then
                            strErrorMessage = "Couldn't find cell """ & strTopLeftCellIdentifier & """ in " & wsCurrentWorksheet.Name
                            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
    Dim j As Long
    Dim k As Long
    Dim l As Long
    Dim 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
    Dim j As Long
    Dim 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
    Dim j As Long
    Dim 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
    Dim 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
    Dim 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(ByRef varScreenUpdating As Variant, ByRef varEnableEvents As Variant, ByRef varCalculation As Variant)
    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(ByRef varScreenUpdating As Variant, ByRef varEnableEvents As Variant, ByRef varCalculation As Variant)
    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

    wbTarget.Activate
    wsTarget.Activate

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

    Dim rngTableRange As Range

        Set rngTableRange = Range(rngStartCell, Cells(rngStartCell.Row + UB1 - LB1, rngStartCell.Column + UB2 - LB2))

        rngTableRange = arrData

End Sub

Public Sub CopyColumn2d(ByRef arrCurrentArray As Variant, ByRef arrDestination As Variant, ByVal lngSourcePosition As Long, ByVal lngDestinationPosition As Long)

    '/ Copy column from one array to another

    Dim i As Long

        For i = LBound(arrCurrentArray) To UBound(arrCurrentArray)
            arrDestination(i, lngDestinationPosition) = arrCurrentArray(i, lngSourcePosition)
        Next i

End Sub