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
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