2 of 2
replaced http://codereview.stackexchange.com/ with https://codereview.stackexchange.com/
Report Building (Data Retrieval, Validation, Aggregation, Business Logic, Report Building, Visual Presentation)
This: enter image description here
Is a data table we get from our financial platform with lots of useful information. For reference, "--" is also the string they use to denote empty values.
This: enter image description here
Is a spreadsheet I built (and had reviewed here) to track our customers' regular income requirements.
The code produces reports to show:
Whether clients with upcoming income have sufficient cash available in their accounts
Which accounts have a large % uninvested (above a minimum threshold value)
Which accounts are not attached to an investment model
A table of account notes appended to each of the above
Overview of the code:
Step 1: Get raw data into arrays
Step 2: Clean said data
Step 3: Produce Reports
Step 4: Print Reports to sheets and Format Presentation
N.B. The worksheet variables are codenames
N.B. There are a number of what I'll call "standard Functions" that appear in the code. You may safely assume that they do what they say they do.
As always, open to any and all feedback, at any level of abstraction. That said, I'm especially interested in the larger project-structure and general maintainability.
Module B1_Public_Variables
Option Explicit
Public Const WB_INCOME_LIST_FILEPATH As String = "S:\Lumin Admin Docs\Ascentric Cash Management\"
Public Const WB_INCOME_LIST_FILENAME As String = "Ascentric Client Income List.xlsm"
Public Const ASCENTRIC_TOP_LEFT_CELL_STRING As String = "Adviser" '/ At present, on row 3
Public Const NOTES_TOP_LEFT_CELL_STRING As String = "Adviser"
'/ Headers for this workbook
Public Const ADVISER_NAME_HEADER As String = "Adviser"
Public Const CLIENT_NAME_HEADER As String = "Client Name"
Public Const ASCENTRIC_NUMBER_HEADER As String = "Client Ref"
Public Const PRODUCT_CODE_HEADER As String = "Product"
Public Const WRAPPER_VALUE_HEADER As String = "Wrapper Value (WV)"
Public Const INVESTMENT_MODEL_HEADER As String = "Model Name"
Public Const DEPOSIT_ACCOUNT_HEADER As String = "Deposit Cash"
Public Const RESERVE_ACCOUNT_HEADER As String = "Reserve Cash"
Public Const INCOME_ACCOUNT_HEADER As String = "Income Account"
Public Const TRADING_ACCOUNT_HEADER As String = "Trading Account"
Public Const SIPP_INCOME_HEADER As String = "SIPP Income £"
Public Const REGULAR_INCOME_HEADER As String = "Reg Income £"
Public Const ACCOUNT_TO_TAKE_INCOME_FROM_HEADER As String = "Income Taken From"
Public Const INCOME_FREQUENCY_HEADER As String = "Income Frequency"
Public Const NEXT_INCOME_DATE_HEADER As String = "Next Send Date"
Public Const NOTES_HEADER As String = "Notes"
'/ Headers for Client Income workbook
Public WsIncClientNameHeader As String
Public WsIncIncomeAmountHeader As String
Public WsIncPaymentFrequencyHeader As String
Public WsIncPaymentDayHeader As String
Public WsIncBaseMonthHeader As String
Public WsIncAscentricWrapperHeader As String
Public WsIncAscentricAccountNumberHeader As String
Public WsIncAccountToPayFromHeader As String
Public WsIncNextIncomeDateHeader As String
'/ Income Report
Public Const SHORTFALL_HEADER As String = "Shortfall?"
Public IncomeReportColumnNumbers As Scripting.Dictionary
'/ Uninvested Cash Report
Public Const DEPOSIT_PERCENT_OF_WRAPPER_HEADER As String = "Deposit Cash % of WV"
Module C1_Main_Sub
Option Explicit
Public Sub GenerateAscentricReports()
StoreApplicationSettings
DisableApplicationSettings
'/========================================================================================================================================================================================================================================================================
'/ Description:
'/========================================================================================================================================================================================================================================================================
'/ Author: Zak Armstrong
'/
'/ Inputs:
'/ A copy-pasted Data Table from Ascentric (provided as MS Excel export). Specifically, the company-wide "Uninvested Cash" Report.
'/ An internal spreadsheet used to track all Ascentric clients who take regular income.
'/ A table of account notes (This Workbook)
'/
'/ Outputs:
'/ A list of all uninvested cash (by account), sorted by % of total account value.
'/ A list of all scheduled income payments, with indications of whether sufficient cash is available to pay it. (Currently only indicated for payments due within 2 weeks)
'/ A list of all Accounts not currently attached to an investment Model
'/ Account Notes appended to the above
'/
'/ Data structure / Unique identifiers:
'/ Ascentric account number. Usually 1 per client (2 if a personal and a joint account). All-digits, no fixed length, no leading zeroes. Typically 8 or 9 digits.
'/ Product codes. Each account can contain multiple products E.G. Pension Account (APA), ISA, General Investment Account (GIA). sometimes more than one of each E.G. APA, APA2, APA3 etc.
'/ Each line in each table refers to one Account number and one product code. If either is missing, data cannot be allocated.
'/========================================================================================================================================================================================================================================================================
'/========================================================================================================================================================================================================================================================================
Dim wbUninvestedCash As Workbook, wbIncomeList As Workbook
Set wbUninvestedCash = ThisWorkbook
Set wbIncomeList = GetWorkbook(WB_INCOME_LIST_FILENAME, WB_INCOME_LIST_FILEPATH)
ActivateAndUnmerge wsAscentricData
Set IncomeReportColumnNumbers = InitialiseIncomeReportColumnNumbers
'/ Ascentric Data Variables ======================================================================================
Dim ascentricDataArray As Variant, ascentricDataRange As Range, ascentricColumnNumbers As Scripting.Dictionary
ascentricDataArray = Array()
Set ascentricDataRange = GetAscentricDataRange
ascentricDataArray = ascentricDataRange
Set ascentricColumnNumbers = GetAscentricColumnIndexes(ascentricDataArray)
'/ Notes Data Variables ======================================================================================
Dim notesDataArray As Variant, notesDataRange As Range
notesDataArray = Array()
Set notesDataRange = GetNotesDataRange
notesDataArray = notesDataRange
'/ Lumin Client Income Data Variables ======================================================================================
Dim luminClientIncomeDataArray As Variant, luminClientIncomeColumnNumbers As Scripting.Dictionary
wbIncomeList.GetDataTableHeaders clientNameHeader:=WsIncClientNameHeader _
, incomeAmountHeader:=WsIncIncomeAmountHeader _
, paymentFrequencyHeader:=WsIncPaymentFrequencyHeader _
, paymentDayHeader:=WsIncPaymentDayHeader _
, baseMonthHeader:=WsIncBaseMonthHeader _
, ascentricWrapperHeader:=WsIncAscentricWrapperHeader _
, ascentricAccountNumberHeader:=WsIncAscentricAccountNumberHeader _
, accountToPayFromHeader:=WsIncAccountToPayFromHeader _
, nextIncomeDateHeader:=WsIncNextIncomeDateHeader
luminClientIncomeDataArray = GetClientIncomeDataArray(wbIncomeList, Year(Now))
Set luminClientIncomeColumnNumbers = GetClientIncomeColumnIndexes(luminClientIncomeDataArray)
CloseWorkbook wbIncomeList
'/ Clean Up data ======================================================================================
CleanUpAscentricData ascentricDataArray
CleanUpNotesData notesDataArray
CleanUpClientIncomeData luminClientIncomeDataArray, luminClientIncomeColumnNumbers
'/ Client Income Data Variables ======================================================================================
Dim ascentricClientIncomeDataArray As Variant, luminIncomeDataArray
ascentricClientIncomeDataArray = GetIncomeFromDataArray(ascentricDataArray, ascentricColumnNumbers)
luminIncomeDataArray = GetIncomeFromDataArray(luminClientIncomeDataArray, luminClientIncomeColumnNumbers, hasAdviser:=False)
AddAccountBalancesAndAdvisersToLuminIncome ascentricDataArray, luminIncomeDataArray
Dim removedIncomeRows As Variant
removedIncomeRows = Array()
removedIncomeRows = InitialiseIncomeArray()
ascentricClientIncomeDataArray = RemoveMissingPayDates(ascentricClientIncomeDataArray, removedIncomeRows)
luminIncomeDataArray = RemoveMissingPayDates(luminIncomeDataArray, removedIncomeRows)
'/ Client Income Report ======================================================================================
'/ In case of collisions between Ascentric and Client Income Workbook, Client Income Workbook takes precedence
Dim incomeReportArray As Variant
incomeReportArray = MergeIncomeArrays(luminIncomeDataArray, ascentricClientIncomeDataArray)
CleanIncomeReportArray incomeReportArray
CleanIncomeReportArray removedIncomeRows
incomeReportArray = AddShortFallColumnToIncomeReport(incomeReportArray)
removedIncomeRows = AddShortFallColumnToIncomeReport(removedIncomeRows)
incomeReportArray = AppendNotes(incomeReportArray, notesDataArray)
removedIncomeRows = AppendNotes(removedIncomeRows, notesDataArray)
'/ "Not Attached To Model" Report ======================================================================================
Dim noModelArray As Variant
noModelArray = GetRowsWithMissingModel(ascentricDataArray)
noModelArray = AppendNotes(noModelArray, notesDataArray)
'/ Uninvested Cash Report ======================================================================================
Dim uninvestedCashReport As Variant
uninvestedCashReport = GetUninvestedCashReport(ascentricDataArray)
uninvestedCashReport = AppendDepositPercentOfWrapper(uninvestedCashReport)
uninvestedCashReport = GetAccountsAboveThresholdValue(uninvestedCashReport, 10000)
uninvestedCashReport = AppendNotes(uninvestedCashReport, notesDataArray)
'/ Print reports + Visual Formatting ======================================================================================
Dim ws As Worksheet
Dim arr As Variant
Set ws = wsClientIncomeReport
arr = incomeReportArray
ws.Cells.Clear
Print2dArrayToSheet wbUninvestedCash, ws, arr, ws.Cells(1, 1)
FormatIncomeReportVisuals arr, ws
Set ws = wsRemovedIncome
arr = removedIncomeRows
ws.Cells.Clear
Print2dArrayToSheet wbUninvestedCash, ws, arr, ws.Cells(1, 1)
FormatIncomeReportVisuals arr, ws
Set ws = wsNoModelAttachedreport
arr = noModelArray
ws.Cells.Clear
Print2dArrayToSheet wbUninvestedCash, ws, arr, ws.Cells(1, 1)
FormatNoModelReportVisuals arr, ws
Set ws = wsUninvestedCashReport
arr = uninvestedCashReport
ws.Cells.Clear
Print2dArrayToSheet wbUninvestedCash, ws, arr, ws.Cells(1, 1)
FormatUninvestedCashReportVisuals arr, ws
RestoreApplicationSettings
End Sub
Module C2_Get_Data_Ranges
Option Explicit
Public Function GetAscentricDataRange() As Range
Set GetAscentricDataRange = GetTableRange(wsAscentricData, ASCENTRIC_TOP_LEFT_CELL_STRING, useCurrentRegion:=False) '/ Not Current Region because un-merging may split table into multiple regions
End Function
Public Function GetNotesDataRange() As Range
Set GetNotesDataRange = GetTableRange(wsAccountNotes, NOTES_TOP_LEFT_CELL_STRING, useCurrentRegion:=False) '/ Not Current Region because un-merging may split table into multiple regions
End Function
Public Function GetTableRange(ByRef ws As Worksheet, ByVal topLeftCellText As String, Optional ByVal useCurrentRegion As Boolean = True)
ws.Activate
Dim dataRange As Range
Dim topLeftCell As Range, searchRange As Range
Set searchRange = ws.Range(Cells(1, 1), Cells(10, 10)) '/ 10x10 is a purely arbitrary search range that should cover almost all typical spreadsheets
Set topLeftCell = CellContainingStringInRange(searchRange, topLeftCellText)
Dim tableFinalRow As Long, tableFinalCol As Long
AssignRangeBoundsOfData topLeftCell, UB1:=tableFinalRow, UB2:=tableFinalCol, useCurrentRegion:=useCurrentRegion '/ Not Current Region because un-merging may split table into multiple regions
Set dataRange = ws.Range(topLeftCell, Cells(tableFinalRow, tableFinalCol))
Set GetTableRange = dataRange
End Function
Module C3_Get_Data_Arrays
Option Explicit
Public Function GetClientIncomeDataArray(ByRef wbIncomeList As Workbook, ByVal ixYear As Long) As Variant
'/ Gets data array from Client Inome Workbook, **then** converts it to use same headers/format as ascentric data.
Dim dataArray As Variant
Dim codenameClientIncomeWs As String
'/ I don't like the hacky nature of this, but it will run fine for the next 2 years by which time I sincerely *hope* we'll have moved to a proper database system
With wbIncomeList
If ixYear = 2015 Then .GetWorksheetCodenames ws2015:=codenameClientIncomeWs
If ixYear = 2016 Then .GetWorksheetCodenames ws2016:=codenameClientIncomeWs
If ixYear = 2017 Then .GetWorksheetCodenames ws2017:=codenameClientIncomeWs
End With
dataArray = wbIncomeList.GetDataArrayFromSheetByCodename(codenameClientIncomeWs)
dataArray = ConvertLuminIncomeToAscentricIncomeFormat(dataArray)
GetClientIncomeDataArray = dataArray
End Function
Module C4_Get_Column_Indexes
It should be noted around here that I originally thought I would store all the arrays' column indexes in dictionaries and then pass those around. By about halfway through the main sub I decided I preferred each function to dynamically determine where column headers are instead.
Option Explicit
Public Function ColumnIndexesOfStringsInArrayRow(ByRef searchStrings As Collection, ByRef dataArray As Variant, ByVal rowToSearch As Long) As Scripting.Dictionary
Dim dict As Scripting.Dictionary
Set dict = New Scripting.Dictionary
Dim arrSearchRow As Variant
arrSearchRow = RowFrom2dArray(dataArray, rowToSearch)
Dim searchText As String, colNum As Long
Dim ix As Long
For ix = 1 To searchStrings.Count
searchText = searchStrings(ix)
colNum = IndexInArray1d(arrSearchRow, searchText)
dict.Add searchText, colNum
Next ix
Set ColumnIndexesOfStringsInArrayRow = dict
End Function
Public Function GetAscentricColumnIndexes(ByRef ascentricDataArray As Variant) As Scripting.Dictionary
Dim headers As Collection
Set headers = GetAscentricHeaders
Dim headerRow As Long
headerRow = LBound(ascentricDataArray, 1)
Dim dict As Scripting.Dictionary
Set dict = ColumnIndexesOfStringsInArrayRow(headers, ascentricDataArray, headerRow)
Set GetAscentricColumnIndexes = dict
End Function
Public Function GetClientIncomeColumnIndexes(ByRef clientIncomeDataArray As Variant) As Scripting.Dictionary
Dim headers As Collection
Set headers = GetClientIncomeHeaders
Dim headerRow As Long
headerRow = LBound(clientIncomeDataArray, 1)
Dim dict As Scripting.Dictionary
Set dict = ColumnIndexesOfStringsInArrayRow(headers, clientIncomeDataArray, headerRow)
Set GetClientIncomeColumnIndexes = dict
End Function
Module C5_Clean_Array_Data
Option Explicit
Public Sub CleanUpAscentricData(ByRef ascentricDataArray As Variant)
Dim valueToReplace As String, replacementValue As Variant
ascentricDataArray = Trim2DArrayValues(ascentricDataArray)
valueToReplace = "--"
replacementValue = CLng("0")
ascentricDataArray = FindAndReplace2DArrayValues(ascentricDataArray, valueToReplace, replacementValue)
valueToReplace = "AGENERAL"
replacementValue = "GIA"
ascentricDataArray = FindAndReplace2DArrayValues(ascentricDataArray, valueToReplace, replacementValue)
valueToReplace = "AGENERAL2"
replacementValue = "GIA2"
ascentricDataArray = FindAndReplace2DArrayValues(ascentricDataArray, valueToReplace, replacementValue)
valueToReplace = "AGENERAL3"
replacementValue = "GIA3"
ascentricDataArray = FindAndReplace2DArrayValues(ascentricDataArray, valueToReplace, replacementValue)
valueToReplace = "AGENERAL4"
replacementValue = "GIA4"
ascentricDataArray = FindAndReplace2DArrayValues(ascentricDataArray, valueToReplace, replacementValue)
Dim headerRow As Variant
headerRow = RowFrom2dArray(ascentricDataArray, 1)
Dim payDateCol As Long
payDateCol = IndexInArray1d(headerRow, NEXT_INCOME_DATE_HEADER)
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
AssignArrayBounds ascentricDataArray, LB1, UB1, LB2, UB2
Dim ix As Long, value As String, payDate As Date
For ix = LB1 + 1 To UB1
value = CStr(ascentricDataArray(ix, payDateCol))
payDate = CDate(value)
ascentricDataArray(ix, payDateCol) = payDate
Next ix
End Sub
Public Sub CleanUpNotesData(ByRef notesDataArray As Variant)
Dim valueToReplace As String, replacementValue As Variant
notesDataArray = Trim2DArrayValues(notesDataArray)
valueToReplace = "AGENERAL"
replacementValue = "GIA"
notesDataArray = FindAndReplace2DArrayValues(notesDataArray, valueToReplace, replacementValue)
valueToReplace = "AGENERAL2"
replacementValue = "GIA2"
notesDataArray = FindAndReplace2DArrayValues(notesDataArray, valueToReplace, replacementValue)
valueToReplace = "AGENERAL3"
replacementValue = "GIA3"
notesDataArray = FindAndReplace2DArrayValues(notesDataArray, valueToReplace, replacementValue)
valueToReplace = "AGENERAL4"
replacementValue = "GIA4"
notesDataArray = FindAndReplace2DArrayValues(notesDataArray, valueToReplace, replacementValue)
End Sub
Public Sub CleanUpClientIncomeData(ByRef clientIncomeDataArray As Variant, ByRef clientIncomeColumnNumbers As Scripting.Dictionary)
Dim ix As Long
clientIncomeDataArray = Trim2DArrayValues(clientIncomeDataArray)
'/ For each of the required columns (and only the required columns), remove "N/A"
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
AssignArrayBounds clientIncomeDataArray, LB1, UB1, LB2, UB2
Dim valueToReplace As String, replacementValue As String
valueToReplace = "N/A"
replacementValue = vbNullString
Dim key As Variant, colNum As Long, columnArray As Variant
For Each key In clientIncomeColumnNumbers.Keys()
colNum = clientIncomeColumnNumbers.item(key)
columnArray = ColumnFrom2dArray(clientIncomeDataArray, colNum)
columnArray = FindAndReplace1DArrayValues(columnArray, valueToReplace, replacementValue)
For ix = LB1 To UB1
clientIncomeDataArray(ix, colNum) = columnArray(ix)
Next ix
Next key
Dim headerRow As Variant
headerRow = RowFrom2dArray(clientIncomeDataArray, 1)
Dim payDateCol As Long
payDateCol = IndexInArray1d(headerRow, NEXT_INCOME_DATE_HEADER)
Dim value As String, payDate As Date
For ix = LB1 + 1 To UB1
value = CStr(clientIncomeDataArray(ix, payDateCol))
payDate = CDate(value)
clientIncomeDataArray(ix, payDateCol) = payDate
Next ix
End Sub
Public Sub CleanIncomeReportArray(ByRef incomeReportArray As Variant)
Dim valueToReplace As String, replacementValue As Variant
valueToReplace = ""
replacementValue = 0
incomeReportArray = FindAndReplace2DArrayValues(incomeReportArray, valueToReplace, replacementValue)
End Sub
Module D1_Income_Report
Option Explicit
Public Function GetIncomeFromDataArray(ByRef dataArray As Variant, ByRef columnNumbers As Scripting.Dictionary, Optional ByVal hasAdviser As Boolean = True) As Variant
Dim numIncomeColumns As Long
Dim newArr As Variant
newArr = Array()
Dim ix As Long, iy As Long
Dim takesIncome As Boolean
Dim LB1 As Long, UB1 As Long
AssignArrayBounds dataArray, LB1, UB1
Dim regIncomeColumn As Long, sippIncomeColumn As Long
regIncomeColumn = columnNumbers.item(REGULAR_INCOME_HEADER)
sippIncomeColumn = columnNumbers.item(SIPP_INCOME_HEADER)
newArr = InitialiseIncomeArray()
numIncomeColumns = UBound(newArr, 2)
Dim sourceColNum As Long, currentRow As Long, header As String, value As Variant
Dim regIncomeAmount As Double, sippIncomeAmount As Double
Dim incomeCount As Long
Transpose2dArray newArr
incomeCount = 0
For ix = LB1 + 1 To UB1 '/ +1 for headers
value = dataArray(ix, regIncomeColumn)
If Len(value) > 0 Then regIncomeAmount = CDbl(dataArray(ix, regIncomeColumn)) Else regIncomeAmount = 0
value = dataArray(ix, sippIncomeColumn)
If Len(value) > 0 Then sippIncomeAmount = CDbl(dataArray(ix, sippIncomeColumn)) Else sippIncomeAmount = 0
takesIncome = (regIncomeAmount > 0 Or sippIncomeAmount > 0)
If takesIncome Then
incomeCount = incomeCount + 1
currentRow = incomeCount + 1 '/ +1 for headers
ReDim Preserve newArr(1 To numIncomeColumns, 1 To currentRow)
For iy = 1 To numIncomeColumns
header = newArr(iy, 1)
sourceColNum = columnNumbers.item(header)
If header = ADVISER_NAME_HEADER Then
If hasAdviser Then
value = dataArray(ix, sourceColNum)
newArr(iy, currentRow) = value
End If
Else
value = dataArray(ix, sourceColNum)
newArr(iy, currentRow) = value
End If
Next iy
End If
Next ix
Transpose2dArray newArr
GetIncomeFromDataArray = newArr
End Function
Public Sub AddAccountBalancesAndAdvisersToLuminIncome(ByRef ascentricIncomeDataArray As Variant, ByRef luminIncomeDataArray As Variant)
'/ Ascentric
Dim ascentricLB1 As Long, ascentricUB1 As Long
Dim ascentricLB2 As Long, ascentricUB2 As Long
AssignArrayBounds ascentricIncomeDataArray, ascentricLB1, ascentricUB1, ascentricLB2, ascentricUB2
Dim ascentricHeaderRow As Variant
ascentricHeaderRow = RowFrom2dArray(ascentricIncomeDataArray, ascentricLB1)
Dim ascentricDepositCol As Long, ascentricReserveCol As Long
Dim ascentricIncomeCol As Long, ascentricTradingCol As Long
ascentricDepositCol = IndexInArray1d(ascentricHeaderRow, DEPOSIT_ACCOUNT_HEADER)
ascentricReserveCol = IndexInArray1d(ascentricHeaderRow, RESERVE_ACCOUNT_HEADER)
ascentricIncomeCol = IndexInArray1d(ascentricHeaderRow, INCOME_ACCOUNT_HEADER)
ascentricTradingCol = IndexInArray1d(ascentricHeaderRow, TRADING_ACCOUNT_HEADER)
Dim ascentricNumberCol As Long, ascentricProductCol As Long
ascentricNumberCol = IndexInArray1d(ascentricHeaderRow, ASCENTRIC_NUMBER_HEADER)
ascentricProductCol = IndexInArray1d(ascentricHeaderRow, PRODUCT_CODE_HEADER)
Dim ascentricAdviserCol As Long
ascentricAdviserCol = IndexInArray1d(ascentricHeaderRow, ADVISER_NAME_HEADER)
'/ Lumin
Dim luminLB1 As Long, luminUB1 As Long
Dim luminLB2 As Long, luminUB2 As Long
AssignArrayBounds luminIncomeDataArray, luminLB1, luminUB1, luminLB2, luminUB2
Dim luminHeaderRow As Variant
luminHeaderRow = RowFrom2dArray(luminIncomeDataArray, luminLB1)
Dim luminDepositCol As Long, luminReserveCol As Long
Dim luminIncomeCol As Long, luminTradingCol As Long
luminDepositCol = IndexInArray1d(luminHeaderRow, DEPOSIT_ACCOUNT_HEADER)
luminReserveCol = IndexInArray1d(luminHeaderRow, RESERVE_ACCOUNT_HEADER)
luminIncomeCol = IndexInArray1d(luminHeaderRow, INCOME_ACCOUNT_HEADER)
luminTradingCol = IndexInArray1d(luminHeaderRow, TRADING_ACCOUNT_HEADER)
Dim luminNumberCol As Long, luminProductCol As Long
luminNumberCol = IndexInArray1d(luminHeaderRow, ASCENTRIC_NUMBER_HEADER)
luminProductCol = IndexInArray1d(luminHeaderRow, PRODUCT_CODE_HEADER)
Dim luminAdviserCol As Long
luminAdviserCol = IndexInArray1d(luminHeaderRow, ADVISER_NAME_HEADER)
Dim ix As Long
Dim i As Long
Dim accountNum As String, product As String
Dim luminUnid As String, ascentricUnid As String
For ix = luminLB1 + 1 To luminUB1
accountNum = luminIncomeDataArray(ix, luminNumberCol)
product = luminIncomeDataArray(ix, luminProductCol)
luminUnid = accountNum & ";" & product
For i = ascentricLB1 To ascentricUB1
accountNum = ascentricIncomeDataArray(i, ascentricNumberCol)
product = ascentricIncomeDataArray(i, ascentricProductCol)
ascentricUnid = accountNum & ";" & product
If luminUnid = ascentricUnid Then
luminIncomeDataArray(ix, luminDepositCol) = ascentricIncomeDataArray(i, ascentricDepositCol)
luminIncomeDataArray(ix, luminReserveCol) = ascentricIncomeDataArray(i, ascentricReserveCol)
luminIncomeDataArray(ix, luminTradingCol) = ascentricIncomeDataArray(i, ascentricTradingCol)
luminIncomeDataArray(ix, luminIncomeCol) = ascentricIncomeDataArray(i, ascentricIncomeCol)
luminIncomeDataArray(ix, luminAdviserCol) = ascentricIncomeDataArray(i, ascentricAdviserCol)
End If
Next i
Next ix
End Sub
Public Function RemoveMissingPayDates(ByRef dataArray As Variant, ByRef removedIncomeRows As Variant) As Variant
Dim ix As Long, iy As Long
Dim sourceLB1 As Long, sourceUB1 As Long
Dim sourceLB2 As Long, sourceUB2 As Long
AssignArrayBounds dataArray, sourceLB1, sourceUB1, sourceLB2, sourceUB2
Dim headerRow As Variant
headerRow = RowFrom2dArray(dataArray, 1)
Dim payDateCol As Long
payDateCol = IndexInArray1d(headerRow, NEXT_INCOME_DATE_HEADER)
Dim filteredArray As Variant
filteredArray = Array()
ReDim filteredArray(1 To 1, sourceLB2 To sourceUB2)
For iy = sourceLB2 To sourceUB2
filteredArray(1, iy) = headerRow(iy)
Next iy
Dim dateIsMissing As Boolean, payDate As Date
Dim filteredRow As Long, removedRow As Long
removedRow = UBound(removedIncomeRows, 1)
filteredRow = 1
Transpose2dArray filteredArray
Transpose2dArray removedIncomeRows
For ix = sourceLB1 + 1 To sourceUB1
payDate = dataArray(ix, payDateCol)
dateIsMissing = Year(payDate) < Year(Now) Or (Year(payDate) = Year(Now) And Month(payDate) < Month(Now)) Or (Year(payDate) = Year(Now) And Month(payDate) = Month(Now) And Day(payDate) < Day(Now))
If dateIsMissing Then
removedRow = removedRow + 1
ReDim Preserve removedIncomeRows(sourceLB2 To sourceUB2, 1 To removedRow)
For iy = sourceLB2 To sourceUB2
removedIncomeRows(iy, removedRow) = dataArray(ix, iy)
Next iy
Else
filteredRow = filteredRow + 1
ReDim Preserve filteredArray(sourceLB2 To sourceUB2, 1 To filteredRow)
For iy = sourceLB2 To sourceUB2
filteredArray(iy, filteredRow) = dataArray(ix, iy)
Next iy
End If
Next ix
Transpose2dArray filteredArray
Transpose2dArray removedIncomeRows
RemoveMissingPayDates = filteredArray
End Function
Public Function AddShortFallColumnToIncomeReport(ByRef incomeReportArray As Variant) As Variant
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
AssignArrayBounds incomeReportArray, LB1, UB1, LB2, UB2
Dim headerRow As Variant
headerRow = RowFrom2dArray(incomeReportArray, LB1)
Dim nextPayDateCol As Long, accountToDrawFromCol As Long, sippAmountCol As Long, regularAmountCol As Long
nextPayDateCol = IndexInArray1d(headerRow, NEXT_INCOME_DATE_HEADER)
accountToDrawFromCol = IndexInArray1d(headerRow, ACCOUNT_TO_TAKE_INCOME_FROM_HEADER)
sippAmountCol = IndexInArray1d(headerRow, SIPP_INCOME_HEADER)
regularAmountCol = IndexInArray1d(headerRow, REGULAR_INCOME_HEADER)
Dim depositAccountCol As Long, reserveAccountCol As Long, incomeAccountCol As Long, tradingAccountCol As Long
depositAccountCol = IndexInArray1d(headerRow, DEPOSIT_ACCOUNT_HEADER)
reserveAccountCol = IndexInArray1d(headerRow, RESERVE_ACCOUNT_HEADER)
incomeAccountCol = IndexInArray1d(headerRow, INCOME_ACCOUNT_HEADER)
tradingAccountCol = IndexInArray1d(headerRow, TRADING_ACCOUNT_HEADER)
UB2 = UB2 + 1
ReDim Preserve incomeReportArray(LB1 To UB1, LB2 To UB2)
incomeReportArray(LB1, UB2) = SHORTFALL_HEADER
Dim shortfallCol As Long
shortfallCol = UB2
Dim indicatedAccount As String, accountCol As Long, accountBalance As Double
Dim sippAmount As Double, regIncomeAmount As Double, incomeAmount As Double
Dim outputString As String, nextPayDate As Date
Dim ix As Long
For ix = LB1 + 1 To UB1
sippAmount = incomeReportArray(ix, sippAmountCol)
regIncomeAmount = incomeReportArray(ix, regularAmountCol)
If sippAmount > regIncomeAmount Then
incomeAmount = sippAmount
Else
incomeAmount = regIncomeAmount
End If
indicatedAccount = incomeReportArray(ix, accountToDrawFromCol)
Select Case indicatedAccount
Case Is = "Deposit"
accountCol = depositAccountCol
Case Is = "Reserve"
accountCol = reserveAccountCol
Case Is = "Trading"
accountCol = tradingAccountCol
Case Is = "Income"
accountCol = incomeAccountCol
End Select
accountBalance = incomeReportArray(ix, accountCol)
nextPayDate = incomeReportArray(ix, nextPayDateCol)
If accountBalance < incomeAmount And (nextPayDate - Now()) <= 14 And (nextPayDate - Now()) >= 0 Then
outputString = "Shortfall"
Else
outputString = ""
End If
incomeReportArray(ix, shortfallCol) = outputString
Next ix
AddShortFallColumnToIncomeReport = incomeReportArray
End Function
Module D2_No_Model_Report
Option Explicit
Public Function GetRowsWithMissingModel(ByRef sourceArray As Variant) As Variant
Dim ix As Long, iy As Long
'/ Source Array
Dim sourceLB1 As Long, sourceUB1 As Long
Dim sourceLB2 As Long, sourceUB2 As Long
AssignArrayBounds sourceArray, sourceLB1, sourceUB1, sourceLB2, sourceUB2
Dim sourceHeaderRow As Variant
sourceHeaderRow = RowFrom2dArray(sourceArray, sourceLB1)
Dim sourceModelCol As Long
sourceModelCol = IndexInArray1d(sourceHeaderRow, INVESTMENT_MODEL_HEADER)
'/ Output Array
Dim outputArray As Variant
outputArray = InitialiseNoModelArray
Dim outputLB1 As Long, outputUB1 As Long
Dim outputLB2 As Long, outputUB2 As Long
AssignArrayBounds outputArray, outputLB1, outputUB1, outputLB2, outputUB2
Dim outputHeaderRow As Variant
outputHeaderRow = RowFrom2dArray(outputArray, outputLB1)
'/ Loop
Dim header As String, sourceCol As Long
Dim model As String, hasModel As Boolean
Dim outputRow As Long
Transpose2dArray sourceArray
Transpose2dArray outputArray
outputRow = outputLB1
For ix = sourceLB1 + 1 To sourceUB1
model = sourceArray(sourceModelCol, ix)
hasModel = (model <> "" And model <> "0")
If Not hasModel Then
outputRow = outputRow + 1
ReDim Preserve outputArray(outputLB2 To outputUB2, outputLB1 To outputRow)
For iy = outputLB2 To outputUB2
header = outputHeaderRow(iy)
sourceCol = IndexInArray1d(sourceHeaderRow, header)
outputArray(iy, outputRow) = sourceArray(sourceCol, ix)
Next iy
End If
Next ix
Transpose2dArray sourceArray
Transpose2dArray outputArray
GetRowsWithMissingModel = outputArray
End Function
Module D3_Uninvested_Cash_Report
Option Explicit
Public Function GetUninvestedCashReport(ByRef sourceArray As Variant) As Variant
Dim ix As Long, iy As Long
'/ Source Array
Dim sourceLB1 As Long, sourceUB1 As Long
Dim sourceLB2 As Long, sourceUB2 As Long
AssignArrayBounds sourceArray, sourceLB1, sourceUB1, sourceLB2, sourceUB2
Dim sourceHeaderRow As Variant
sourceHeaderRow = RowFrom2dArray(sourceArray, sourceLB1)
'/ Output Array
Dim outputArray As Variant
outputArray = InitialiseUninvestedCashArray
Dim outputLB1 As Long, outputUB1 As Long
Dim outputLB2 As Long, outputUB2 As Long
AssignArrayBounds outputArray, outputLB1, outputUB1, outputLB2, outputUB2
Dim outputHeaderRow As Variant
outputHeaderRow = RowFrom2dArray(outputArray, outputLB1)
'/ Loop
Dim header As String, sourceCol As Long
Dim outputRow As Long
Transpose2dArray sourceArray
Transpose2dArray outputArray
outputRow = outputLB1
For ix = sourceLB1 + 1 To sourceUB1
outputRow = outputRow + 1
ReDim Preserve outputArray(outputLB2 To outputUB2, outputLB1 To outputRow)
For iy = outputLB2 To outputUB2
header = outputHeaderRow(iy)
sourceCol = IndexInArray1d(sourceHeaderRow, header)
outputArray(iy, outputRow) = sourceArray(sourceCol, ix)
Next iy
Next ix
Transpose2dArray sourceArray
Transpose2dArray outputArray
GetUninvestedCashReport = outputArray
End Function
Public Function AppendDepositPercentOfWrapper(sourceArray) As Variant
'/ source
Dim sourceLB1 As Long, sourceUB1 As Long
Dim sourceLB2 As Long, sourceUB2 As Long
AssignArrayBounds sourceArray, sourceLB1, sourceUB1, sourceLB2, sourceUB2
ReDim Preserve sourceArray(sourceLB1 To sourceUB1, sourceLB2 To sourceUB2 + 1)
sourceUB2 = sourceUB2 + 1
sourceArray(sourceLB1, sourceUB2) = DEPOSIT_PERCENT_OF_WRAPPER_HEADER
Dim sourceHeaderRow As Variant
sourceHeaderRow = RowFrom2dArray(sourceArray, sourceLB1)
Dim sourceDepositPercentCol As Long
sourceDepositPercentCol = sourceUB2
Dim sourceWrapperCol As Long, sourceDepositCol As Long
sourceWrapperCol = IndexInArray1d(sourceHeaderRow, WRAPPER_VALUE_HEADER)
sourceDepositCol = IndexInArray1d(sourceHeaderRow, DEPOSIT_ACCOUNT_HEADER)
Dim ix As Long
Dim wrapperValue As Double, depositValue As Double, percentValue As Double
For ix = sourceLB1 + 1 To sourceUB1
wrapperValue = sourceArray(ix, sourceWrapperCol)
depositValue = sourceArray(ix, sourceDepositCol)
If wrapperValue > 0 Then
percentValue = depositValue / wrapperValue
sourceArray(ix, sourceDepositPercentCol) = percentValue
End If
Next ix
AppendDepositPercentOfWrapper = sourceArray
End Function
Public Function GetAccountsAboveThresholdValue(ByRef sourceArray As Variant, ByVal minimumValue As Double) As Variant
Dim ix As Long, iy As Long
'/ Source Array
Dim sourceLB1 As Long, sourceUB1 As Long
Dim sourceLB2 As Long, sourceUB2 As Long
AssignArrayBounds sourceArray, sourceLB1, sourceUB1, sourceLB2, sourceUB2
Dim sourceHeaderRow As Variant
sourceHeaderRow = RowFrom2dArray(sourceArray, sourceLB1)
Dim sourceWrapperCol As Long
sourceWrapperCol = IndexInArray1d(sourceHeaderRow, WRAPPER_VALUE_HEADER)
'/ Output Array
Dim outputArray As Variant
outputArray = InitialiseUninvestedCashArray
Dim outputLB1 As Long, outputUB1 As Long
Dim outputLB2 As Long, outputUB2 As Long
AssignArrayBounds outputArray, outputLB1, outputUB1, outputLB2, outputUB2
outputUB2 = outputUB2 + 1
ReDim Preserve outputArray(outputLB1 To outputUB1, outputLB2 To outputUB2)
outputArray(outputLB1, outputUB2) = DEPOSIT_PERCENT_OF_WRAPPER_HEADER
Dim outputHeaderRow As Variant
outputHeaderRow = RowFrom2dArray(outputArray, outputLB1)
'/ Loop
Dim header As String, sourceCol As Long
Dim wrapper As Double
Dim outputRow As Long
Transpose2dArray sourceArray
Transpose2dArray outputArray
outputRow = outputLB1
For ix = sourceLB1 + 1 To sourceUB1
wrapper = sourceArray(sourceWrapperCol, ix)
If wrapper >= minimumValue Then
outputRow = outputRow + 1
ReDim Preserve outputArray(outputLB2 To outputUB2, outputLB1 To outputRow)
For iy = outputLB2 To outputUB2
header = outputHeaderRow(iy)
sourceCol = IndexInArray1d(sourceHeaderRow, header)
outputArray(iy, outputRow) = sourceArray(sourceCol, ix)
Next iy
End If
Next ix
Transpose2dArray sourceArray
Transpose2dArray outputArray
GetAccountsAboveThresholdValue = outputArray
End Function
Module E5_Visual_Formatting
I've removed this module because it is the least complex (lots of column formatting, row colouring, area bordering etc.) and because I was hitting the character limit.
Module B2_Project_Settings_And_Methods
Option Explicit
Public Function InitialiseNoModelArray() As Variant
Dim noModelArray As Variant
noModelArray = Array()
ReDim noModelArray(1 To 1, 1 To 4)
noModelArray(1, 1) = CLIENT_NAME_HEADER
noModelArray(1, 2) = ASCENTRIC_NUMBER_HEADER
noModelArray(1, 3) = PRODUCT_CODE_HEADER
noModelArray(1, 4) = WRAPPER_VALUE_HEADER
InitialiseNoModelArray = noModelArray
End Function
Public Function InitialiseUninvestedCashArray() As Variant
Dim uninvestedCashArray As Variant
uninvestedCashArray = Array()
ReDim uninvestedCashArray(1 To 1, 1 To 6)
uninvestedCashArray(1, 1) = ADVISER_NAME_HEADER
uninvestedCashArray(1, 2) = CLIENT_NAME_HEADER
uninvestedCashArray(1, 3) = ASCENTRIC_NUMBER_HEADER
uninvestedCashArray(1, 4) = PRODUCT_CODE_HEADER
uninvestedCashArray(1, 5) = WRAPPER_VALUE_HEADER
uninvestedCashArray(1, 6) = DEPOSIT_ACCOUNT_HEADER
InitialiseUninvestedCashArray = uninvestedCashArray
End Function
Public Function ConvertLuminIncomeToAscentricIncomeFormat(ByRef luminIncomeDataArray As Variant) As Variant
'/ Payment day/ Base month --> Next pay date.
Dim convertedArray As Variant
convertedArray = Array()
CopyArrayContents2d luminIncomeDataArray, convertedArray
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
AssignArrayBounds luminIncomeDataArray, LB1, UB1, LB2, UB2
'/ Convert Headers
Dim oldHeader As String, newHeader As String
Dim headerRow As Long, iy As Long
headerRow = LB1
For iy = LB2 To UB2
oldHeader = luminIncomeDataArray(headerRow, iy)
Select Case oldHeader
Case Is = WsIncClientNameHeader
newHeader = CLIENT_NAME_HEADER
Case Is = WsIncIncomeAmountHeader
newHeader = REGULAR_INCOME_HEADER
Case Is = WsIncPaymentFrequencyHeader
newHeader = INCOME_FREQUENCY_HEADER
Case Is = WsIncAscentricWrapperHeader
newHeader = PRODUCT_CODE_HEADER
Case Is = WsIncAscentricAccountNumberHeader
newHeader = ASCENTRIC_NUMBER_HEADER
Case Is = WsIncAccountToPayFromHeader
newHeader = ACCOUNT_TO_TAKE_INCOME_FROM_HEADER
Case Is = WsIncNextIncomeDateHeader
newHeader = NEXT_INCOME_DATE_HEADER
Case Else
newHeader = oldHeader
End Select
convertedArray(headerRow, iy) = newHeader
Next iy
'/ Add missing Columns
ReDim Preserve convertedArray(LB1 To UB1, LB2 To UB2 + 5) '/ +5 for missing columns
convertedArray(headerRow, UB2 + 1) = DEPOSIT_ACCOUNT_HEADER
convertedArray(headerRow, UB2 + 2) = RESERVE_ACCOUNT_HEADER
convertedArray(headerRow, UB2 + 3) = INCOME_ACCOUNT_HEADER
convertedArray(headerRow, UB2 + 4) = TRADING_ACCOUNT_HEADER
convertedArray(headerRow, UB2 + 5) = SIPP_INCOME_HEADER
ConvertLuminIncomeToAscentricIncomeFormat = convertedArray
End Function
Public Function GetAscentricHeaders() As Collection
Dim col As Collection
Set col = New Collection
col.Add ADVISER_NAME_HEADER
col.Add CLIENT_NAME_HEADER
col.Add ASCENTRIC_NUMBER_HEADER
col.Add PRODUCT_CODE_HEADER
col.Add WRAPPER_VALUE_HEADER
col.Add INVESTMENT_MODEL_HEADER
col.Add DEPOSIT_ACCOUNT_HEADER
col.Add RESERVE_ACCOUNT_HEADER
col.Add INCOME_ACCOUNT_HEADER
col.Add TRADING_ACCOUNT_HEADER
col.Add SIPP_INCOME_HEADER
col.Add REGULAR_INCOME_HEADER
col.Add INCOME_FREQUENCY_HEADER
col.Add ACCOUNT_TO_TAKE_INCOME_FROM_HEADER
col.Add NEXT_INCOME_DATE_HEADER
Set GetAscentricHeaders = col
End Function
Public Function GetClientIncomeHeaders() As Collection
Dim col As Collection
Set col = New Collection
col.Add WsIncClientNameHeader
col.Add REGULAR_INCOME_HEADER
col.Add INCOME_FREQUENCY_HEADER
col.Add WsIncPaymentDayHeader
col.Add WsIncBaseMonthHeader
col.Add PRODUCT_CODE_HEADER
col.Add ASCENTRIC_NUMBER_HEADER
col.Add ACCOUNT_TO_TAKE_INCOME_FROM_HEADER
col.Add NEXT_INCOME_DATE_HEADER
col.Add DEPOSIT_ACCOUNT_HEADER
col.Add RESERVE_ACCOUNT_HEADER
col.Add INCOME_ACCOUNT_HEADER
col.Add TRADING_ACCOUNT_HEADER
col.Add SIPP_INCOME_HEADER
Set GetClientIncomeHeaders = col
End Function
Public Function InitialiseIncomeReportColumnNumbers() As Scripting.Dictionary
Dim dict As Scripting.Dictionary
Set dict = New Scripting.Dictionary
Dim header As String, colNum As Long
header = ADVISER_NAME_HEADER
colNum = 1
dict.Add header, colNum
header = CLIENT_NAME_HEADER
colNum = colNum + 1
dict.Add header, colNum
header = ASCENTRIC_NUMBER_HEADER
colNum = colNum + 1
dict.Add header, colNum
header = PRODUCT_CODE_HEADER
colNum = colNum + 1
dict.Add header, colNum
header = RESERVE_ACCOUNT_HEADER
colNum = colNum + 1
dict.Add header, colNum
header = DEPOSIT_ACCOUNT_HEADER
colNum = colNum + 1
dict.Add header, colNum
header = INCOME_ACCOUNT_HEADER
colNum = colNum + 1
dict.Add header, colNum
header = TRADING_ACCOUNT_HEADER
colNum = colNum + 1
dict.Add header, colNum
header = ACCOUNT_TO_TAKE_INCOME_FROM_HEADER
colNum = colNum + 1
dict.Add header, colNum
header = SIPP_INCOME_HEADER
colNum = colNum + 1
dict.Add header, colNum
header = REGULAR_INCOME_HEADER
colNum = colNum + 1
dict.Add header, colNum
header = INCOME_FREQUENCY_HEADER
colNum = colNum + 1
dict.Add header, colNum
header = NEXT_INCOME_DATE_HEADER
colNum = colNum + 1
dict.Add header, colNum
Set InitialiseIncomeReportColumnNumbers = dict
End Function
Public Function InitialiseIncomeArray() As Variant
Dim dataArray As Variant
dataArray = Array()
Dim minCol As Long, maxCol As Long, colNum As Long
Dim key As Variant
Dim isFirstKey As Boolean
isFirstKey = True
For Each key In IncomeReportColumnNumbers.Keys()
colNum = IncomeReportColumnNumbers.item(key)
If isFirstKey Then
minCol = colNum
isFirstKey = False
End If
If colNum > maxCol Then maxCol = colNum
If colNum < minCol Then minCol = colNum
Next key
ReDim dataArray(1 To 1, minCol To maxCol)
Dim header As String
For Each key In IncomeReportColumnNumbers.Keys()
header = key
colNum = IncomeReportColumnNumbers.item(key)
dataArray(1, colNum) = header
Next key
InitialiseIncomeArray = dataArray
End Function
Public Function MergeIncomeArrays(ByRef primaryArray As Variant, ByRef secondaryArray As Variant) As Variant
Dim mergedArray As Variant
mergedArray = InitialiseIncomeArray()
Dim unidHeader As String
unidHeader = ASCENTRIC_NUMBER_HEADER
'/ From this point on, all operations defined in terms of source/target arrays
mergedArray = AddOrMergeIntoArray(primaryArray, mergedArray, unidHeader, PRODUCT_CODE_HEADER, NEXT_INCOME_DATE_HEADER)
mergedArray = AddOrMergeIntoArray(secondaryArray, mergedArray, unidHeader, PRODUCT_CODE_HEADER, NEXT_INCOME_DATE_HEADER)
MergeIncomeArrays = mergedArray
End Function
Public Function AddOrMergeIntoArray(ByRef sourceArray As Variant, ByRef targetArray As Variant, ByVal firstUnidHeader As String, ByVal secondUnidHeader As String, ByVal thirdUnidHeader As String) As Variant
'/ Assumptions: Headers are always in the lowest row of an Array
'/ The headers in the source Array are a strict subset of the headers in the larger Array
'/ Values "", 0 and vbNullString represent empty data to be replaced
Dim unidsInReport As Scripting.Dictionary
Set unidsInReport = New Scripting.Dictionary
Dim sourceHeaderRow As Variant, targetHeaderRow As Variant
Dim sourceFirstUnidColNum As Long, targetFirstUnidColNum As Long
Dim sourceSecondUnidColNum As Long, targetSecondUnidColNum As Long
Dim sourceThirdUnidColNum As Long, targetThirdUnidColNum As Long
Dim sourceValue As Variant, targetValue As Variant
Dim sourceRow As Long, targetRow As Long
Dim sourceColumn As Long, targetColumn As Long
Dim sourceLB1 As Long, sourceUB1 As Long
Dim sourceLB2 As Long, sourceUB2 As Long
AssignArrayBounds sourceArray, sourceLB1, sourceUB1, sourceLB2, sourceUB2
Dim targetLB1 As Long, targetUB1 As Long
Dim targetLB2 As Long, targetUB2 As Long
AssignArrayBounds targetArray, targetLB1, targetUB1, targetLB2, targetUB2
sourceHeaderRow = RowFrom2dArray(sourceArray, sourceLB1)
targetHeaderRow = RowFrom2dArray(targetArray, targetLB1)
sourceFirstUnidColNum = IndexInArray1d(sourceHeaderRow, firstUnidHeader)
targetFirstUnidColNum = IndexInArray1d(targetHeaderRow, firstUnidHeader)
sourceSecondUnidColNum = IndexInArray1d(sourceHeaderRow, secondUnidHeader)
targetSecondUnidColNum = IndexInArray1d(targetHeaderRow, secondUnidHeader)
sourceThirdUnidColNum = IndexInArray1d(sourceHeaderRow, thirdUnidHeader)
targetThirdUnidColNum = IndexInArray1d(targetHeaderRow, thirdUnidHeader)
Dim firstUnid As String, secondUnid As String, thirdUnid As String
Dim unid As String, header As String
Dim ix As Long, iy As Long
'/ add unids to dictionary
For ix = targetLB1 + 1 To targetUB1 '/ +1 for headers
firstUnid = targetArray(ix, targetFirstUnidColNum)
secondUnid = targetArray(ix, targetSecondUnidColNum)
thirdUnid = CStr(targetArray(ix, targetThirdUnidColNum))
unid = firstUnid & ";" & secondUnid & ";" & thirdUnid
unidsInReport.Add unid, ix
Next ix
Transpose2dArray targetArray
'/ Add or Merge
For ix = sourceLB1 + 1 To sourceUB1
firstUnid = sourceArray(ix, sourceFirstUnidColNum)
secondUnid = sourceArray(ix, sourceSecondUnidColNum)
thirdUnid = CStr(sourceArray(ix, sourceThirdUnidColNum))
unid = firstUnid & ";" & secondUnid & ";" & thirdUnid
sourceRow = ix
If unidsInReport.Exists(unid) Then
targetRow = unidsInReport.item(unid)
Else
targetRow = UBound(targetArray, 2) + 1 '/ currently transposed so 2nd dimension = rows
ReDim Preserve targetArray(targetLB2 To targetUB2, 1 To targetRow)
End If
For iy = sourceLB2 To sourceUB2
header = sourceHeaderRow(iy)
sourceColumn = iy
targetColumn = IndexInArray1d(targetHeaderRow, header)
sourceValue = sourceArray(sourceRow, sourceColumn)
If unidsInReport.Exists(unid) Then
targetValue = targetArray(targetColumn, targetRow) '/ currently transposed
If targetValue = vbNullString Or targetValue = "" Or targetValue = 0 Then
targetArray(targetColumn, targetRow) = sourceValue
End If
Else
targetArray(targetColumn, targetRow) = sourceValue
End If
Next iy
Next ix
Transpose2dArray targetArray
AddOrMergeIntoArray = targetArray
End Function
Public Function AppendNotes(ByRef targetArray As Variant, ByRef notesArray As Variant) As Variant
'/ notes
Dim notesLB1 As Long, notesUB1 As Long
Dim notesLB2 As Long, notesUB2 As Long
AssignArrayBounds notesArray, notesLB1, notesUB1, notesLB2, notesUB2
Dim notesHeaderRow As Variant
notesHeaderRow = RowFrom2dArray(notesArray, notesLB1)
Dim notesNotesCol As Long
notesNotesCol = IndexInArray1d(notesHeaderRow, NOTES_HEADER)
Dim notesAccountCol As Long, notesProductCol As Long
notesAccountCol = IndexInArray1d(notesHeaderRow, ASCENTRIC_NUMBER_HEADER)
notesProductCol = IndexInArray1d(notesHeaderRow, PRODUCT_CODE_HEADER)
'/ target
Dim targetLB1 As Long, targetUB1 As Long
Dim targetLB2 As Long, targetUB2 As Long
AssignArrayBounds targetArray, targetLB1, targetUB1, targetLB2, targetUB2
ReDim Preserve targetArray(targetLB1 To targetUB1, targetLB2 To targetUB2 + 1)
targetUB2 = targetUB2 + 1
targetArray(targetLB1, targetUB2) = NOTES_HEADER
Dim targetHeaderRow As Variant
targetHeaderRow = RowFrom2dArray(targetArray, targetLB1)
Dim targetNotesCol As Long
targetNotesCol = IndexInArray1d(targetHeaderRow, NOTES_HEADER)
Dim targetAccountCol As Long, targetProductCol As Long
targetAccountCol = IndexInArray1d(targetHeaderRow, ASCENTRIC_NUMBER_HEADER)
targetProductCol = IndexInArray1d(targetHeaderRow, PRODUCT_CODE_HEADER)
Dim ix As Long
Dim i As Long
Dim accountNum As String, product As String
Dim targetUnid As String, notesUnid As String
For ix = notesLB1 + 1 To notesUB1
accountNum = notesArray(ix, notesAccountCol)
product = notesArray(ix, notesProductCol)
notesUnid = accountNum & ";" & product
For i = notesLB1 To notesUB1
accountNum = targetArray(i, targetAccountCol)
product = targetArray(i, targetProductCol)
targetUnid = accountNum & ";" & product
If targetUnid = notesUnid Then
targetArray(i, targetNotesCol) = notesArray(ix, notesNotesCol)
End If
Next i
Next ix
AppendNotes = targetArray
End Function
Kaz
- 8.8k
- 2
- 31
- 69
lang-vb