PropertyComparer Class Implementing IComparer with ArrayList

By implementing the MScorlib IComparer Interface, my PropertyComparer Class enables the sorting Objects added to an ArrayList by the their properties. You can also determine if an Object is in the ArrayList using a BinarySearch.

In order to do a BinarySearch you will need to sort the list with a PropertyComparer and then pass it to the the ArrayList.BinarySearch method.

This requires a MScorlib reference be set

There are a few nuances to consider when implementing MScorlib objects in the VBA.

• Methods and properties of the MScorlib objects are not visible to IntelliSense or the Locals Window

• Overloaded Methods are renamed. Generally, the first method in the MSDN documentation would be normal and the subsequent methods would be enumerated with an underscore

  • BinarySearch(Int32,Int32,Object,IComparer) -> BinarySearch(Long,Long,Object,IComparer)

  • BinarySearch(Object) => BinarySearch_2(Object)

  • BinarySearch(Object, IComparer) => BinarySearch_3(Object, IComparer)

In my demo I use ArrayList.Sort_2 pc and ArrayList.BinarySearch_3(Object, IComparer)

In this Demo I show how you can sort Ranges in an ArrayList by their various properties. The PropertyComparer is not limited to just Ranges; it can be applied to any Object whose 1st level property returns either a value or an Object that has a default value.

Class: PropertyComparer

Implements mscorlib.IComparer

Private mArgs As Variant
Private mCallType As VbCallType
Private mProcName As String

Public Function IComparer_Compare(ByVal X As Variant, ByVal Y As Variant) As Long
    Dim x1 As Variant, y1 As Variant
    If Len(mProcName) = 0 Then
        x1 = X
        y1 = Y
    Else
        x1 = CallFunction(X)
        y1 = CallFunction(Y)
    End If
    If TypeName(x1) = "String" Then
        IComparer_Compare = StrComp(x1, y1, vbTextCompare)
    Else
        If x1 > y1 Then
            IComparer_Compare = 1
        ElseIf x1 < y1 Then
            IComparer_Compare = -1
        End If
    End If
End Function

Public Sub Init(ProcName As String, CallType As VbCallType, ParamArray Args())
    mProcName = ProcName
    mCallType = CallType
    mArgs = Args
End Sub

' http://www.vbforums.com/showthread.php?405366-RESOLVED-Using-CallByName-with-variable-number-of-arguments
' Author: Joacim Andersson
Private Function CallFunction(Object As Variant)
    Select Case UBound(mArgs)
        Case -1
            CallFunction = CallByName(Object, mProcName, mCallType)
        Case 0
            CallFunction = CallByName(Object, mProcName, mCallType, Val(mArgs(0)))
        Case 1
            CallFunction = CallByName(Object, mProcName, mCallType, Val(mArgs(0)), Val(mArgs(1)))
        Case 2
            CallFunction = CallByName(Object, mProcName, mCallType, Val(mArgs(0)), Val(mArgs(1)), Val(mArgs(2)))
        Case 3
            CallFunction = CallByName(Object, mProcName, mCallType, Val(mArgs(0)), Val(mArgs(1)), Val(mArgs(2)), Val(mArgs(3)))
        Case 4
            CallFunction = CallByName(Object, mProcName, mCallType, Val(mArgs(0)), Val(mArgs(1)), Val(mArgs(2)), Val(mArgs(3)), Val(mArgs(4)))
    End Select
End Function

Userform1 Code

Public OrdersList As mscorlib.ArrayList
Private pc As PropertyComparer

Private Sub UserForm_Initialize()
    Dim cell As Range
    Set OrdersList = New ArrayList
    Set pc = New PropertyComparer

    With Worksheets("Orders")
        For Each cell In .Range("A2", .Range("A" & .Rows.count).End(xlUp))
            OrdersList.Add cell.Resize(1, 8)
        Next

        For Each cell In .Range("A1").Resize(1, 8)
            cboSortBy.AddItem cell.Value
        Next

    End With

    cboSortBy.AddItem "Row"

    FillOrdersListBox
End Sub

Private Sub btnFindCarmenSandiego_Click()
    Dim cell As Range
    OrdersList.Clear
    With Worksheets("Orders")
        For Each cell In .Range("A2", .Range("A" & .Rows.count).End(xlUp)).Resize(, 8)
            OrdersList.Add cell
        Next
    End With

    pc.Init "Address", VbGet, 0, 0, xlA1, -1
    OrdersList.Sort_2 pc
    FillOrdersListBox
    lboOrders.ColumnWidths = ""
    lboOrders.ListIndex = OrdersList.BinarySearch_3(Range("CarmenSandiego"), pc)
End Sub

Private Sub btnReverse_Click()
    OrdersList.Reverse
    FillOrdersListBox
End Sub

Private Sub cboSortBy_Change()
    If cboSortBy.ListIndex = -1 Then Exit Sub

    Select Case cboSortBy.ListIndex
        Case Is < 8
            pc.Init "Cells", VbGet, 1, cboSortBy.ListIndex + 1
        Case 8
            pc.Init "Row", VbGet
    End Select

    OrdersList.Sort_2 pc
    FillOrdersListBox
End Sub

Sub FillOrdersListBox()
    lboOrders.list = WorksheetFunction.Transpose(WorksheetFunction.Transpose(OrdersList.ToArray))
End Sub

Any advice on adding Comments, Error Handlers, or functionality would be appreciated.