VBA 对象数组排序算法分享

 

Function SrotObjectByProperty(objsToSort As Variant, PropertyName As String, Optional 降序 As Boolean = True)
    If IsEmpty(objsToSort) Then Exit Function
    If InStr(TypeName(objsToSort), "()") < 1 Then Exit Function 'IsArray() is somewhat broken: Look for brackets in the type name
    Dim m As Long, n As Long, compareRtn As Integer
    Dim temp As Variant, temp1 As Variant
    For m = LBound(objsToSort) To UBound(objsToSort)
        For n = m To UBound(objsToSort)
            Set temp = objsToSort(n)
            Set temp1 = objsToSort(m)
            'https://docs.microsoft.com/zh-cn/office/vba/language/reference/user-interface-help/strcomp-function
            Dim nValue As Variant, mValue As Variant
            nValue = CallByName(objsToSort(n), PropertyName, VbGet)
            mValue = CallByName(objsToSort(m), PropertyName, VbGet)
            compareRtn = VBA.StrComp(nValue, mValue, vbTextCompare)
            If VBA.IsNumeric(nValue) Then
                If nValue < mValue And 降序 Then
                    'ElementSwap objsToSort(n), objsToSort(m)
                    Set objsToSort(n) = temp1
                    Set objsToSort(m) = temp
                ElseIf nValue > mValue And Not 降序 Then
                    'ElementSwap objsToSort(n), objsToSort(m)
                    Set objsToSort(n) = temp1
                    Set objsToSort(m) = temp
                End If
            Else
                If compareRtn = -1 And 降序 Then
                    'ElementSwap objsToSort(n), objsToSort(m)
                    Set objsToSort(n) = temp1
                    Set objsToSort(m) = temp
                ElseIf compareRtn = 1 And Not 降序 Then
                    'ElementSwap objsToSort(n), objsToSort(m)
                    Set objsToSort(n) = temp1
                    Set objsToSort(m) = temp
                End If
            End If
        Next n
    Next m
End Function