10
\$\begingroup\$

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
\$\endgroup\$
3
\$\begingroup\$

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.

\$\endgroup\$
1
\$\begingroup\$

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... :/

\$\endgroup\$
1
  • \$\begingroup\$ I wouldn't delete it. It's a useful answer. \$\endgroup\$ – Kaz Dec 14 '15 at 18:11

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.