Creating a pseudo Pivot Table / Database using a 4-D array

Question

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

Answer 1

Code is clean, the Hungarian naming is just slightly annoying, but variables have meaningful names, and that's good.

If I had to bring up just one thing, I'd bring up the non-standard indentation. I see your patterns there, and you seem to be following some convention - but it's non-standard nonetheless: Dim and ReDim are executable statements just like any other, I'm not sure why you're doing this:

 FindAllProviders
ReDim ArrAllocatedBusiness(0 To UBound(ArrAdvisers), 0 To ColMetrics.Count, 0 To UBound(ArrProviders), 0 To 13)
 PrepareAllocatedBusinessHeadings

Not a big thing, it's just... distracting.

Also...

 For i = LB1 + 1 To UB1
 For j = LB2 + 1 To UB2
 For k = LB3 + 1 To UB3
 '...
 Next k
 Next j
 Next i

I see what you're doing, but I don't agree. Nested loops should look like nested loops, and them being indented as such makes it much easier to see:

 For i = LB1 + 1 To UB1
 For j = LB2 + 1 To UB2
 For k = LB3 + 1 To UB3
 '...
 Next k
 Next j
 Next i

Stackin/aligning them the way you did, makes it look like you somewhat want to hide the fact that you've got a 3-layer nested loop going on.

---

 Case Is = ColMetrics.Item("Recurring")
 '/ do nothing

Why bother then? And if you're only ever going to run code when strTypeOfBusiness is not "Recurring", then the Select Case block reeks of YAGNI here, a regular If block would raise fewer (削除) questions (削除ここまで) eyebrows, especially with a comment that explains why we only care about non-recurring business here, when other methods handle several types differently.

---

Looking deeper, I'm not sure I like CheckErrorConditionsBusinessType at all. If should be returning that Boolean value (with an Optional ByRef outMessage = vbNullString), and leave it up to the caller to determine what to do with the return value, and whether to pop a messagebox or stick the message in the host app's statusbar.

The conditions should all be mutually exclusive, or each block should include an early return (Exit Function) - otherwise you make it look like the last block is the most important one, because it will always execute and overwrite whatever validation errors occurred before that, effectively having executed as many lines of code and made as many assignments for no reason: just return and report the first error, and don't bother validating the other conditions - the validation has already failed anyway.

Answer 2

while some parts can be easily be collapsed like this: (halfway done/looks ugly as it is right now)

Public Sub PrepareAllocatedBusinessHeadings()
 Dim i As Long, j As Long, k As Long
 Dim LB(4) As Long, UB(4) As Long
 AssignArrayBounds ArrAllocatedBusiness, LB(1), UB(1), LB(2), UB(2), LB(3), UB(3), LB(4), UB(4)
 For i = LB(1) + 1 To UB(1)
 ArrAllocatedBusiness(i, 0, 0, 0) = ArrAdvisers(i)
 ArrAllocatedBusiness(0, i, 0, 0) = ColMetrics(j)
 ArrAllocatedBusiness(0, 0, i, 0) = ArrProviders(k)
 For j = LB(2) + 1 To UB(2)
 ArrAllocatedBusiness(i, j, 0, 0) = ArrAdvisers(i) & Hyphen & ColMetrics(j)
 For k = LB(3) + 1 To UB(3)
 ArrAllocatedBusiness(i, j, k, 0) = ArrAllocatedBusiness(i, j, 0, 0) & Hyphen & ArrProviders(k)
 Next k
 Next j
 Next i
 For i = LB(4) + 1 To UB(4) - 1
 ArrAllocatedBusiness(0, 0, 0, i) = DateValue(Format(Month(i), """01/""00/") & Year(Date))
 Next i
 ArrAllocatedBusiness(0, 0, 0, UB(4)) = "YTD"
End Sub

...others like DetermineAllocatedBusinessIndexes can not (and they look like, you could simplyfy them a lot)... simply cus a lot of functions/subs are missing and it is not known how they work (knowing some data is fetched ByRef)...

I'm pretty sure a lot of the extremely long-named variables could be skipped out just by changig the way the data interacts with itself...

I'll post this so you may get an idea how to improve your code... but it probably will be deleted in some days cus i can't improve it any further lookig at what is provided... :/

• Kaz: I wouldn't delete it. It's a useful answer.