Why am I not just using a Pivot Table / Database?
- a) I've never ever used either before. And I don't have time to learn how before this project needs to actually be finished.
- b) The final output is going to be a report for the Company Directors. As such, the flexibility of choosing which bits of data to output in what format in which table on what sheet is highly useful.
I already have my raw data aggregated, validated and consistently formatted in a single table. This part of the Macro takes each line and:
- Determines which Financial Adviser is involved.
- Determines what type of business is involved (investments, insurance, premiums, invoives, management fees etc.).
- Determines which Financial Service provider is involved, if any (e.g. insurance providers, fund managers etc.).
- Determines which month the business was transacted in.
then aggregates the results into a 4-D array (Advisers, BusinessType, Providers, Month).
I am aware that alongside a pivot table, learning how to use dictionaries and an actual database would be useful. Given that those weren't options here, is there any other feedback you can offer?
N.B. I've tried to make my macro as robust as possible, so there's a lot of Find/Check position of <heading> in <Table/Array>. This report is going to primarily be used by other people, and absolutely has to be 100% accurate, so I feel it's warranted.
Also, some of the basic methods aren't included here. You can safely assume that they do what they say they do.
Module 10: M10_Allocate_Business
Public Sub AllocateBusinessToAdvisersProvidersMonthsAndMetrics()
PutSheetDataInArray WbAdviserReport, WsAggregatedData, ArrAggregatedData
FindAllAdvisers
FindAllProviders
ReDim ArrAllocatedBusiness(0 To UBound(ArrAdvisers), 0 To ColMetrics.Count, 0 To UBound(ArrProviders), 0 To 13)
PrepareAllocatedBusinessHeadings
AllocateAggregatedBusiness
End Sub
Public Sub FindAllAdvisers()
Dim arrHeadingsRow As Variant
Dim ixColumnHeading As Long
Dim arrAdviserColumn As Variant
arrHeadingsRow = RowFrom2dArray(ArrAggregatedData, 1)
ixColumnHeading = IndexInArray1d(arrHeadingsRow, "Adviser")
arrAdviserColumn = ColumnFrom2dArray(ArrAggregatedData, ixColumnHeading)
ArrAdvisers = ListOfUniqueValues(arrAdviserColumn, True)
End Sub
Public Sub FindAllProviders()
Dim arrHeadingsRow As Variant
Dim ixColumnPosition As Long
Dim arrProviderColumn As Variant
arrHeadingsRow = RowFrom2dArray(ArrAggregatedData, 1)
ixColumnPosition = IndexInArray1d(arrHeadingsRow, "Life Co")
arrProviderColumn = ColumnFrom2dArray(ArrAggregatedData, ixColumnPosition)
ArrProviders = ListOfUniqueValues(arrProviderColumn, True)
End Sub
Public Sub PrepareAllocatedBusinessHeadings()
Dim i As Long, j As Long, k As Long, l As Long
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
AssignArrayBounds ArrAllocatedBusiness, LB1, UB1, LB2, UB2, LB3, UB3, LB4, UB4
For i = LB1 + 1 To UB1
ArrAllocatedBusiness(i, 0, 0, 0) = ArrAdvisers(i)
Next i
For i = LB1 + 1 To UB1
For j = LB2 + 1 To UB2
ArrAllocatedBusiness(0, j, 0, 0) = ColMetrics(j)
ArrAllocatedBusiness(i, j, 0, 0) = ArrAdvisers(i) & Hyphen & ColMetrics(j)
Next j
Next i
For i = LB1 + 1 To UB1
For j = LB2 + 1 To UB2
For k = LB3 + 1 To UB3
ArrAllocatedBusiness(0, 0, k, 0) = ArrProviders(k)
ArrAllocatedBusiness(i, j, k, 0) = ArrAdvisers(i) & Hyphen & ColMetrics(j) & Hyphen & ArrProviders(k)
Next k
Next j
Next i
For l = LB4 + 1 To UB4 - 1
ArrAllocatedBusiness(0, 0, 0, l) = DateValue("01/" & Right("0" & Month(l), 2) & "/" & Year(Date))
Next l
ArrAllocatedBusiness(0, 0, 0, UB4) = "YTD"
End Sub
Public Sub AllocateAggregatedBusiness()
Dim i As Long, j As Long, k As Long
Dim row As Long
Dim lngFirstRow As Long, lngFinalRow As Long '/ Of the AggregatedData
Dim strTypeOfBusiness As String
Dim ixAdviserColumn As Long
Dim ixProviderColumn As Long
Dim ixDateSubmittedColumn As Long
Dim ixInvestmentAmountColumn As Long
Dim ixDateMoneyReceivedColumn As Long
Dim ixMonthlyPremiumColumn As Long
Dim ixSinglePremiumColumn As Long
Dim ixCommissionDueColumn As Long
Dim ixCommissionPaidColumn As Long
Dim ixDateCommissionPaidColumn As Long
Dim ixFirstMonthColumn As Long
Dim ixAdviser As Long
Dim ixMetric As Long
Dim ixProvider As Long
Dim ixMonth As Long
Dim varSearchValue As Variant
Dim strErrorMessage As String
DetermineColumnPositions ixAdviserColumn, ixProviderColumn, ixDateSubmittedColumn, ixInvestmentAmountColumn, ixDateMoneyReceivedColumn, ixMonthlyPremiumColumn, _
ixSinglePremiumColumn, ixCommissionDueColumn, ixCommissionPaidColumn, ixDateCommissionPaidColumn, ixFirstMonthColumn
AssignArrayBounds ArrAggregatedData, lngFirstRow, lngFinalRow
lngFirstRow = lngFirstRow + 2
For row = lngFirstRow To lngFinalRow
strTypeOfBusiness = TypeOfBusiness(row, ixDateSubmittedColumn, ixInvestmentAmountColumn, ixDateMoneyReceivedColumn, ixMonthlyPremiumColumn, ixSinglePremiumColumn, _
ixCommissionDueColumn, ixCommissionPaidColumn, ixDateCommissionPaidColumn, ixFirstMonthColumn)
Select Case strTypeOfBusiness
Case Is = ColMetrics.Item("Investment Amount")
DetermineAllocatedBusinessIndexes row, ixAdviser, ixAdviserColumn, ixMetric, ixInvestmentAmountColumn, ixProvider, ixProviderColumn, ixMonth, ixDateSubmittedColumn, strTypeOfBusiness
AllocateBusiness ixInvestmentAmountColumn, ixAdviser, ixMetric, ixProvider, ixMonth, row
Case Is = ColMetrics.Item("Single Premium")
DetermineAllocatedBusinessIndexes row, ixAdviser, ixAdviserColumn, ixMetric, ixSinglePremiumColumn, ixProvider, ixProviderColumn, ixMonth, ixDateSubmittedColumn, strTypeOfBusiness
AllocateBusiness ixSinglePremiumColumn, ixAdviser, ixMetric, ixProvider, ixMonth, row
Case Is = ColMetrics.Item("Monthly Premium")
DetermineAllocatedBusinessIndexes row, ixAdviser, ixAdviserColumn, ixMetric, ixMonthlyPremiumColumn, ixProvider, ixProviderColumn, ixMonth, ixDateSubmittedColumn, strTypeOfBusiness
AllocateBusiness ixMonthlyPremiumColumn, ixAdviser, ixMetric, ixProvider, ixMonth, row
Case Is = ColMetrics.Item("Invoice")
DetermineAllocatedBusinessIndexes row, ixAdviser, ixAdviserColumn, ixMetric, ixCommissionDueColumn, ixProvider, ixProviderColumn, ixMonth, ixDateSubmittedColumn, strTypeOfBusiness
AllocateBusiness ixCommissionDueColumn, ixAdviser, ixMetric, ixProvider, ixMonth, row
Case Is = ColMetrics.Item("Recurring")
For i = 1 To 12
ixMonth = i
DetermineAllocatedBusinessIndexes row, ixAdviser, ixAdviserColumn, ixMetric, ixFirstMonthColumn, ixProvider, ixProviderColumn, ixMonth, ixDateSubmittedColumn, strTypeOfBusiness
AllocateBusiness ixFirstMonthColumn, ixAdviser, ixMetric, ixProvider, ixMonth, row
Next i
End Select
Next row
End Sub
Public Function TypeOfBusiness(ByVal row As Long, ByRef ixDateSubmittedColumn As Long, ByRef ixInvestmentAmountColumn As Long, ByRef ixDateMoneyReceivedColumn As Long, _
ByRef ixMonthlyPremiumColumn As Long, ByRef ixSinglePremiumColumn As Long, ByRef ixCommissionDueColumn As Long, _
ByRef ixCommissionPaidColumn As Long, ByRef ixDateCommissionPaidColumn As Long, ByRef ixFirstMonthColumn As Long) As String
Dim strBusiness As String
strBusiness = ""
Dim bDateSubmittedIsPresent As Boolean
Dim bSubmittedAmountIsPresent As Boolean
Dim bMultipleBusinessTypesArePresent As Boolean
Dim bRecurringBusinessIsPresent As Boolean
Dim bCommissionIsPresent As Boolean
Dim bValuePresent As Boolean
Dim varElement As Variant
Dim i As Long
Dim arrAmountColumns As Variant
arrAmountColumns = Array()
ReDim arrAmountColumns(1 To 3, 1 To 2)
arrAmountColumns(1, 1) = ixInvestmentAmountColumn
arrAmountColumns(1, 2) = ColMetrics.Item("Investment Amount")
arrAmountColumns(2, 1) = ixSinglePremiumColumn
arrAmountColumns(2, 2) = ColMetrics.Item("Single Premium")
arrAmountColumns(3, 1) = ixMonthlyPremiumColumn
arrAmountColumns(3, 2) = ColMetrics.Item("Monthly Premium")
Dim LB1 As Long, UB1 As Long
AssignArrayBounds arrAmountColumns, LB1, UB1
varElement = ArrAggregatedData(row, ixDateSubmittedColumn)
bDateSubmittedIsPresent = (IsDate(varElement) And Not IsEmpty(varElement))
bSubmittedAmountIsPresent = False
For i = LB1 To UB1
varElement = ArrAggregatedData(row, arrAmountColumns(i, 1))
bValuePresent = (IsNumeric(varElement) And Not IsEmpty(varElement) And varElement <> 0)
If bValuePresent And bSubmittedAmountIsPresent Then bMultipleBusinessTypesArePresent = True
If bValuePresent And Not bSubmittedAmountIsPresent Then bSubmittedAmountIsPresent = True
If bValuePresent Then strBusiness = arrAmountColumns(i, 2)
Next i
For i = ixFirstMonthColumn To ixFirstMonthColumn + 11
varElement = ArrAggregatedData(row, i)
If (IsNumeric(varElement) And Not IsEmpty(varElement) And varElement <> 0) Then bRecurringBusinessIsPresent = True
Next i
If bRecurringBusinessIsPresent Then strBusiness = ColMetrics.Item("Recurring")
varElement = ArrAggregatedData(row, ixCommissionDueColumn)
bCommissionIsPresent = (IsNumeric(varElement) And Not IsEmpty(varElement) And varElement <> 0)
If Not (bSubmittedAmountIsPresent Or bRecurringBusinessIsPresent) And bCommissionIsPresent Then strBusiness = ColMetrics.Item("Invoice")
CheckErrorConditionsBusinessType row, bDateSubmittedIsPresent, bSubmittedAmountIsPresent, bMultipleBusinessTypesArePresent, bRecurringBusinessIsPresent, bCommissionIsPresent
TypeOfBusiness = strBusiness
End Function
Public Sub CheckErrorConditionsBusinessType(ByVal row As Long, ByVal bDateSubmittedIsPresent As Boolean, ByVal bSubmittedAmountIsPresent As Boolean, _
ByVal bMultipleBusinessTypesArePresent As Boolean, ByVal bRecurringBusinessIsPresent As Boolean, ByVal bCommissionIsPresent As Boolean)
Dim bError As Boolean
Dim strErrorMessage As String
'/ Check for: Multiple types of submitted business, submitted and recurring, submitted without date, no business at all
bError = False
If bMultipleBusinessTypesArePresent _
Then
bError = True
strErrorMessage = strErrorMessage & "Found Multiple Types of Submitted Business on line: " & row
End If
If bSubmittedAmountIsPresent And bRecurringBusinessIsPresent _
Then
bError = True
strErrorMessage = strErrorMessage & "Found Submitted and Recurring Business on line: " & row
End If
If Not (bSubmittedAmountIsPresent Or bRecurringBusinessIsPresent Or bCommissionIsPresent) _
Then
bError = True
strErrorMessage = strErrorMessage & "Could not find any submitted or recurring business on line: " & row
End If
If bSubmittedAmountIsPresent And Not bDateSubmittedIsPresent _
Then
bError = True
strErrorMessage = strErrorMessage & "No Date Submitted for business on line: " & row
End If
If bError = True Then ErrorMessage strErrorMessage
End Sub
Public Sub DetermineAllocatedBusinessIndexes(ByVal row As Long, ByRef ixAdviser As Long, ByRef ixAdviserColumn As Long, ByRef ixMetric As Long, ByRef ixMetricColumn As Long, _
ByRef ixProvider As Long, ByRef ixProviderColumn As Long, ByRef ixMonth As Long, ByRef ixDateColumn As Long, ByRef strTypeOfBusiness As String)
Dim i As Long
Dim varSearchValue As Variant
Dim strErrorMessage As String
Dim lngDimension As Long
Dim arrMetrics As Variant
arrMetrics = Array()
ReDim arrMetrics(1 To ColMetrics.Count)
For i = 1 To ColMetrics.Count
arrMetrics(i) = ColMetrics(i)
Next i
varSearchValue = ArrAggregatedData(row, ixAdviserColumn)
ixAdviser = IndexInArray1d(ArrAdvisers, varSearchValue)
varSearchValue = ColMetrics.Item(strTypeOfBusiness)
ixMetric = IndexInArray1d(arrMetrics, varSearchValue)
varSearchValue = ArrAggregatedData(row, ixProviderColumn)
ixProvider = IndexInArray1d(ArrProviders, varSearchValue)
Select Case strTypeOfBusiness
Case Is <> ColMetrics.Item("Recurring")
ixMonth = 0
varSearchValue = ArrAggregatedData(row, ixDateColumn)
ixMonth = Month(varSearchValue)
If ixMonth = 0 _
Then
strErrorMessage = "Could not determine month of " & varSearchValue & " on row: " & row
ErrorMessage strErrorMessage
End If
Case Is = ColMetrics.Item("Recurring")
'/ do nothing
End Select
End Sub
Public Sub AllocateBusiness(ByRef ixBusinessColumn As Long, ByRef ixAdviser As Long, ByRef ixMetric As Long, ByRef ixProvider As Long, ByRef ixMonth As Long, ByVal row As Long)
Dim i As Long, j As Long, k As Long
Dim strErrorMessage As String
Dim dblCurrentValue As Double
Dim dblAdditionalValue As Double
Dim dblNewValue As Double
dblCurrentValue = ArrAllocatedBusiness(ixAdviser, ixMetric, ixProvider, ixMonth)
dblAdditionalValue = ArrAggregatedData(row, ixBusinessColumn)
dblNewValue = dblCurrentValue + dblAdditionalValue
ArrAllocatedBusiness(ixAdviser, ixMetric, ixProvider, ixMonth) = dblNewValue
End Sub
