Since I know a lot of people who come here do so for Excel-related posts, I thought it would be useful to rewrite last week’s Pareto frontiers function in VBA for Excel.

Remember that 2D Pareto frontiers are the set of options which can’t be bettered on one metric without making things worse on the other metric. In the graph below, the options highlighted on the Pareto frontier are those where better quality options can only be had by increasing the cost you are willing to pay. All of the other options can be bettered on both quality and cost by at least one other option.

Rewriting the code for VBA is instructional for two reasons. First, it shows the power of Python, and why I’ve been using it more and more lately. The code I wrote in Python required just 13 lines without having to import any other modules. This VBA code was much more work as I had to adapt Andy Pope’s BubbleSort() to behave like Python’s sorted(), including the reverse option. And even if VBA had had a convenient native way to sort, the rest of the code is also fiddly, requiring loops to populate arrays and for arrays to be re-dimensioned rather than having a simple array.append() method.

Nevertheless, there are clear benefits to working with Excel. Not least the familiarity, auditability and simplicity of generating numbers on the spreadsheet. I still use Excel to write drafts of any numerical calculations and often to mock up GUIs, even if it will be translated into another language at a later date.

So in the spirit of making tools available, here’s the code rewritten for VBA. As with the Python code it takes two equally-sized arrays, but unlike the Python code it returns the Pareto frontier as a 2D array rather than as two lists.

Function FindPareto(Xs As Variant, Ys As Variant, _
                    Optional maxX As Boolean = True, _
                    Optional maxY As Boolean = True)
Dim myArray() As Variant
Dim myParetoFrontier() As Variant
Dim i, k As Long
    ReDim myArray(UBound(Xs) - 1, 1)
    For i = 0 To UBound(Xs) - 1
        myArray(i, 0) = Xs(i + 1, 1)
        myArray(i, 1) = Ys(i + 1, 1)
    Next
' Sort the array on the X values, stating if you want large Xs on the Pareto front
    myArray = BubbleSort(myArray, 0, maxX)
' Start the Pareto frontier with the first value in the sorted list
    ReDim myParetoFrontier(1, 0)
    k = 0
    myParetoFrontier(0, k) = myArray(0, 0)
    myParetoFrontier(1, k) = myArray(0, 1)
    k = k + 1
' Loop through the sorted list
    For i = 1 To UBound(Xs) - 1
        If maxY Then ' Pull out the largest values for Y
            If myArray(i, 1) >= myParetoFrontier(UBound(myParetoFrontier), k - 1) Then
                ReDim Preserve myParetoFrontier(1, k)
                myParetoFrontier(0, k) = myArray(i, 0)
                myParetoFrontier(1, k) = myArray(i, 1)
                k = k + 1
            End If
        Else ' Pull out the smallest values for Y
            If myArray(i, 1) <= myParetoFrontier(UBound(myParetoFrontier), k - 1) Then
                ReDim Preserve myParetoFrontier(1, k)
                myParetoFrontier(0, k) = myArray(i, 0)
                myParetoFrontier(1, k) = myArray(i, 1)
                k = k + 1
            End If
        End If
    Next i
    FindPareto = myParetoFrontier
End Function

And the adapted BubbbleSort() function is as follows. BubbleSort is a notoriously slow algorithm but is about the simplest to implement in VBA (without creating and deleting a new worksheet as an intermediate stage, which has its own drawbacks). You shouldn't have too much difficulty substituting a different sort function if you need to work with very large arrays.

Function BubbleSort(TempArray() As Variant, _
                    Optional Descending As Boolean = True)
Dim NoSwaps As Boolean
Dim Item As Long
Dim Temp(0 To 1) As Variant
Dim Col As Long
    Do
        NoSwaps = True
        For Item = LBound(TempArray) To UBound(TempArray) - 1
            If Descending Then ' Equivalent to the Reverse = True option in the Python Sorted() code
                If TempArray(Item, 0) < TempArray(Item + 1, 0) Then
                    NoSwaps = False
                    For Col = 0 To 1
                        Temp(Col) = TempArray(Item, Col)
                        TempArray(Item, Col) = TempArray(Item + 1, Col)
                        TempArray(Item + 1, Col) = Temp(Col)
                    Next
                End If
            Else
                If TempArray(Item, 0) > TempArray(Item + 1, 0) Then
                    NoSwaps = False
                    For Col = 0 To 1
                        Temp(Col) = TempArray(Item, Col)
                        TempArray(Item, Col) = TempArray(Item + 1, Col)
                        TempArray(Item + 1, Col) = Temp(Col)
                    Next
                End If
            End If
        Next
    Loop While Not NoSwaps
    BubbleSort = TempArray
End Function

And to make things nice and simple, here's a piece of test code you can adapt for calling the function. Just put some values into the range A1:B25 in Sheet 1 and run the macro.

Sub Test()
Dim Xs As Variant
Dim Ys As Variant
Dim i As Integer
Dim myPareto() As Variant
    Xs = Sheets("Sheet1").Range("A1:A25")
    Ys = Sheets("Sheet1").Range("B1:B25")
    Sheets("Sheet1").Range("C1:D25").ClearContents
' Change the options here if you want to prefer smaller values for X and/or larger values for Y
    myPareto = Application.WorksheetFunction.Transpose(FindPareto(Xs, Ys, maxX=True, maxY=False))
    For i = 1 To UBound(myPareto)
        Sheets("Sheet1").Cells(i, 3).Value = myPareto(i, 1)
        Sheets("Sheet1").Cells(i, 4).Value = myPareto(i, 2)
        Debug.Print myPareto(i, 1) & ", " & myPareto(i, 2)
    Next
End Sub