How do I sort a collection?

后端 未结 9 1963
臣服心动
臣服心动 2020-11-27 05:03

Does anyone know how to sort a collection in VBA?

相关标签:
9条回答
  • 2020-11-27 06:02

    Collection is a rather wrong object for sorting.

    The very point of a collection is to provide very fast access to a certain element identified by a key. How the items are stored internally should be irrelevant.

    You might want to consider using arrays instead of collections if you actually need sorting.


    Other than that, yes, you can sort items in a collection.
    You need to take any sorting algorithm available on the Internet (you can google inplementations in basically any language) and make a minor change where a swap occurs (other changes are unnecessary as vba collections, like arrays, can be accessed with indices). To swap two items in a collection, you need to remove them both from the collection and insert them back at the right positions (using the third or the forth parameter of the Add method).

    0 讨论(0)
  • 2020-11-27 06:04

    This is a VBA implementation of the QuickSort algorithm, which is often a better alternative to MergeSort:

    Public Sub QuickSortSortableObjects(colSortable As collection, Optional bSortAscending As Boolean = True, Optional iLow1, Optional iHigh1)
        Dim obj1 As Object
        Dim obj2 As Object
        Dim clsSortable As ISortableObject, clsSortable2 As ISortableObject
        Dim iLow2 As Long, iHigh2 As Long
        Dim vKey As Variant
        On Error GoTo PtrExit
    
        'If not provided, sort the entire collection
        If IsMissing(iLow1) Then iLow1 = 1
        If IsMissing(iHigh1) Then iHigh1 = colSortable.Count
    
        'Set new extremes to old extremes
        iLow2 = iLow1
        iHigh2 = iHigh1
    
        'Get the item in middle of new extremes
        Set clsSortable = colSortable.Item((iLow1 + iHigh1) \ 2)
        vKey = clsSortable.vSortKey
    
        'Loop for all the items in the collection between the extremes
        Do While iLow2 < iHigh2
    
            If bSortAscending Then
                'Find the first item that is greater than the mid-Contract item
                Set clsSortable = colSortable.Item(iLow2)
                Do While clsSortable.vSortKey < vKey And iLow2 < iHigh1
                    iLow2 = iLow2 + 1
                    Set clsSortable = colSortable.Item(iLow2)
                Loop
    
                'Find the last item that is less than the mid-Contract item
                Set clsSortable2 = colSortable.Item(iHigh2)
                Do While clsSortable2.vSortKey > vKey And iHigh2 > iLow1
                    iHigh2 = iHigh2 - 1
                    Set clsSortable2 = colSortable.Item(iHigh2)
                Loop
            Else
                'Find the first item that is less than the mid-Contract item
                Set clsSortable = colSortable.Item(iLow2)
                Do While clsSortable.vSortKey > vKey And iLow2 < iHigh1
                    iLow2 = iLow2 + 1
                    Set clsSortable = colSortable.Item(iLow2)
                Loop
    
                'Find the last item that is greater than the mid-Contract item
                Set clsSortable2 = colSortable.Item(iHigh2)
                Do While clsSortable2.vSortKey < vKey And iHigh2 > iLow1
                    iHigh2 = iHigh2 - 1
                    Set clsSortable2 = colSortable.Item(iHigh2)
                Loop
            End If
    
            'If the two items are in the wrong order, swap the rows
            If iLow2 < iHigh2 And clsSortable.vSortKey <> clsSortable2.vSortKey Then
                Set obj1 = colSortable.Item(iLow2)
                Set obj2 = colSortable.Item(iHigh2)
                colSortable.Remove iHigh2
                If iHigh2 <= colSortable.Count Then _
                    colSortable.Add obj1, Before:=iHigh2 Else colSortable.Add obj1
                colSortable.Remove iLow2
                If iLow2 <= colSortable.Count Then _
                    colSortable.Add obj2, Before:=iLow2 Else colSortable.Add obj2
            End If
    
            'If the Contracters are not together, advance to the next item
            If iLow2 <= iHigh2 Then
                iLow2 = iLow2 + 1
                iHigh2 = iHigh2 - 1
            End If
        Loop
    
        'Recurse to sort the lower half of the extremes
        If iHigh2 > iLow1 Then QuickSortSortableObjects colSortable, bSortAscending, iLow1, iHigh2
    
        'Recurse to sort the upper half of the extremes
        If iLow2 < iHigh1 Then QuickSortSortableObjects colSortable, bSortAscending, iLow2, iHigh1
    
    PtrExit:
    End Sub
    

    The objects stored in the collection must implement the ISortableObject interface, which must be defined in your VBA project. To do that, add a class module called ISortableObject with the following code:

    Public Property Get vSortKey() As Variant
    End Property
    
    0 讨论(0)
  • 2020-11-27 06:07

    This is my implementation of BubbleSort:

    Public Function BubbleSort(ByRef colInput As Collection, _
                                        Optional asc = True) As Collection
    
        Dim temp                    As Variant
        Dim counterA                As Long
        Dim counterB                As Long
    
        For counterA = 1 To colInput.Count - 1
            For counterB = counterA + 1 To colInput.Count
                Select Case asc
                Case True:
                    If colInput(counterA) > colInput(counterB) Then
                        temp = colInput(counterB)
                        colInput.Remove counterB
                        colInput.Add temp, temp, counterA
                    End If
    
                Case False:
                    If colInput(counterA) < colInput(counterB) Then
                        temp = colInput(counterB)
                        colInput.Remove counterB
                        colInput.Add temp, temp, counterA
                    End If
                End Select
            Next counterB
        Next counterA
    
        Set BubbleSort = colInput
    
    End Function
    
    Public Sub TestMe()
    
        Dim myCollection    As New Collection
        Dim element         As Variant
    
        myCollection.Add "2342"
        myCollection.Add "vityata"
        myCollection.Add "na"
        myCollection.Add "baba"
        myCollection.Add "ti"
        myCollection.Add "hvarchiloto"
        myCollection.Add "stackoveflow"
        myCollection.Add "beta"
        myCollection.Add "zuzana"
        myCollection.Add "zuzan"
        myCollection.Add "2z"
        myCollection.Add "alpha"
    
        Set myCollection = BubbleSort(myCollection)
    
        For Each element In myCollection
            Debug.Print element
        Next element
    
        Debug.Print "--------------------"
    
        Set myCollection = BubbleSort(myCollection, False)
    
        For Each element In myCollection
            Debug.Print element
        Next element
    
    End Sub
    

    It takes the collection by reference, thus it can easily return it as a function and it has an optional parameter for Ascending and Descending sorting. The sorting returns this in the immediate window:

    2342
    2z
    alpha
    baba
    beta
    hvarchiloto
    na
    stackoveflow
    ti
    vityata
    zuzan
    zuzana
    --------------------
    zuzana
    zuzan
    vityata
    ti
    stackoveflow
    na
    hvarchiloto
    beta
    baba
    alpha
    2z
    2342
    
    0 讨论(0)
提交回复
热议问题