vba 如何对集合进行排序？

How do I sort a collection?

提问by l--''''''---------''''''''''''

Does anyone know how to sort a collection in VBA?

有谁知道如何在 VBA 中对集合进行排序？

采纳答案by Dick Kusleika

The code below from this post uses a bubble sort

这篇文章下面的代码使用了冒泡排序

Sub SortCollection()

    Dim cFruit As Collection
    Dim vItm As Variant
    Dim i As Long, j As Long
    Dim vTemp As Variant

    Set cFruit = New Collection

    'fill the collection
    cFruit.Add "Mango", "Mango"
    cFruit.Add "Apple", "Apple"
    cFruit.Add "Peach", "Peach"
    cFruit.Add "Kiwi", "Kiwi"
    cFruit.Add "Lime", "Lime"

    'Two loops to bubble sort
    For i = 1 To cFruit.Count - 1
        For j = i + 1 To cFruit.Count
            If cFruit(i) > cFruit(j) Then
                'store the lesser item
                vTemp = cFruit(j)
                'remove the lesser item
                cFruit.Remove j
                're-add the lesser item before the
                'greater Item
                cFruit.Add vTemp, vTemp, i
            End If
        Next j
    Next i

    'Test it
    For Each vItm In cFruit
        Debug.Print vItm
    Next vItm

End Sub

回答by Austin D

Late to the game... here's an implementation of the MergeSort algorithmin VBA for both Arrays and Collections. I tested the performance of this implementation against the BubbleSort implementation in the accepted answer using randomly generated strings. The chart below summarizes the results, i.e. that you should not use BubbleSort to sort a VBA collection.

游戏迟到了……这里是VBA 中数组和集合的MergeSort 算法的实现。我使用随机生成的字符串在接受的答案中针对 BubbleSort 实现测试了此实现的性能。下图总结了结果，即您不应使用 BubbleSort 对 VBA 集合进行排序。

You can download the source code from my GitHub Repositoryor just copy/paste the source code below into the appropriate modules.

您可以从我的GitHub 存储库下载源代码，也可以将下面的源代码复制/粘贴到相应的模块中。

For a collection col, just call Collections.sort col.

对于集合col，只需调用Collections.sort col.

Collections module

收藏模块

'Sorts the given collection using the Arrays.MergeSort algorithm.
' O(n log(n)) time
' O(n) space
Public Sub sort(col As collection, Optional ByRef c As IVariantComparator)
    Dim a() As Variant
    Dim b() As Variant
    a = Collections.ToArray(col)
    Arrays.sort a(), c
    Set col = Collections.FromArray(a())
End Sub

'Returns an array which exactly matches this collection.
' Note: This function is not safe for concurrent modification.
Public Function ToArray(col As collection) As Variant
    Dim a() As Variant
    ReDim a(0 To col.count)
    Dim i As Long
    For i = 0 To col.count - 1
        a(i) = col(i + 1)
    Next i
    ToArray = a()
End Function

'Returns a Collection which exactly matches the given Array
' Note: This function is not safe for concurrent modification.
Public Function FromArray(a() As Variant) As collection
    Dim col As collection
    Set col = New collection
    Dim element As Variant
    For Each element In a
        col.Add element
    Next element
    Set FromArray = col
End Function

Arrays module

数组模块

    Option Compare Text
Option Explicit
Option Base 0

Private Const INSERTIONSORT_THRESHOLD As Long = 7

'Sorts the array using the MergeSort algorithm (follows the Java legacyMergesort algorithm
'O(n*log(n)) time; O(n) space
Public Sub sort(ByRef a() As Variant, Optional ByRef c As IVariantComparator)

    If c Is Nothing Then
        MergeSort copyOf(a), a, 0, length(a), 0, Factory.newNumericComparator
    Else
        MergeSort copyOf(a), a, 0, length(a), 0, c
    End If
End Sub


Private Sub MergeSort(ByRef src() As Variant, ByRef dest() As Variant, low As Long, high As Long, off As Long, ByRef c As IVariantComparator)
    Dim length As Long
    Dim destLow As Long
    Dim destHigh As Long
    Dim mid As Long
    Dim i As Long
    Dim p As Long
    Dim q As Long

    length = high - low

    ' insertion sort on small arrays
    If length < INSERTIONSORT_THRESHOLD Then
        i = low
        Dim j As Long
        Do While i < high
            j = i
            Do While True
                If (j <= low) Then
                    Exit Do
                End If
                If (c.compare(dest(j - 1), dest(j)) <= 0) Then
                    Exit Do
                End If
                swap dest, j, j - 1
                j = j - 1 'decrement j
            Loop
            i = i + 1 'increment i
        Loop
        Exit Sub
    End If

    'recursively sort halves of dest into src
    destLow = low
    destHigh = high
    low = low + off
    high = high + off
    mid = (low + high) / 2
    MergeSort dest, src, low, mid, -off, c
    MergeSort dest, src, mid, high, -off, c

    'if list is already sorted, we're done
    If c.compare(src(mid - 1), src(mid)) <= 0 Then
        copy src, low, dest, destLow, length - 1
        Exit Sub
    End If

    'merge sorted halves into dest
    i = destLow
    p = low
    q = mid
    Do While i < destHigh
        If (q >= high) Then
           dest(i) = src(p)
           p = p + 1
        Else
            'Otherwise, check if p<mid AND src(p) preceeds scr(q)
            'See description of following idom at: https://stackoverflow.com/a/3245183/3795219
            Select Case True
               Case p >= mid, c.compare(src(p), src(q)) > 0
                   dest(i) = src(q)
                   q = q + 1
               Case Else
                   dest(i) = src(p)
                   p = p + 1
            End Select
        End If

        i = i + 1
    Loop

End Sub

IVariantComparator class

IVariantComparator 类

Option Explicit

'The IVariantComparator provides a method, compare, that imposes a total ordering over a collection _
of variants. A class that implements IVariantComparator, called a Comparator, can be passed to the _
Arrays.sort and Collections.sort methods to precisely control the sort order of the elements.

'Compares two variants for their sort order. Returns -1 if v1 should be sorted ahead of v2; +1 if _
v2 should be sorted ahead of v1; and 0 if the two objects are of equal precedence. This function _
should exhibit several necessary behaviors: _
  1.) compare(x,y)=-(compare(y,x) for all x,y _
  2.) compare(x,y)>= 0 for all x,y _
  3.) compare(x,y)>=0 and compare(y,z)>=0 implies compare(x,z)>0 for all x,y,z
Public Function compare(ByRef v1 As Variant, ByRef v2 As Variant) As Long
End Function

If no IVariantComparatoris provided to the sortmethods, then the natural ordering is assumed. However, if you need to define a different sort order (e.g. reverse) or if you want to sort custom objects, you can implement the IVariantComparatorinterface. For example, to sort in reverse order, just create a class called CReverseComparatorwith the following code:

如果没有IVariantComparator为sort方法提供，则假定为自然顺序。但是，如果您需要定义不同的排序顺序（例如反向）或者如果您想对自定义对象进行排序，则可以实现该IVariantComparator接口。例如，要以相反的顺序排序，只需创建一个CReverseComparator使用以下代码调用的类：

CReverseComparator class

CReverseComparator 类

Option Explicit

Implements IVariantComparator

Public Function IVariantComparator_compare(v1 As Variant, v2 As Variant) As Long
    IVariantComparator_compare = v2-v1
End Function

Then call the sort function as follows: Collections.sort col, New CReverseComparator

然后调用排序函数如下： Collections.sort col, New CReverseComparator

Bonus Material:For a visual comparison of the performance of different sorting algorithms check out https://www.toptal.com/developers/sorting-algorithms/

奖励材料：有关不同排序算法性能的视觉比较，请查看https://www.toptal.com/developers/sorting-algorithms/

回答by ameisenmann

You could use a ListView. Although it is a UI object, you can use its functionality. It supports sorting. You can store data in Listview.ListItemsand then sort like this:

你可以使用一个ListView. 虽然它是一个 UI 对象，但您可以使用它的功能。它支持排序。您可以将数据存储在其中Listview.ListItems，然后像这样排序：

Dim lv As ListView
Set lv = New ListView

lv.ListItems.Add Text:="B"
lv.ListItems.Add Text:="A"

lv.SortKey = 0            ' sort based on each item's Text
lv.SortOrder = lvwAscending
lv.Sorted = True
MsgBox lv.ListItems(1)    ' returns "A"
MsgBox lv.ListItems(2)    ' returns "B"

回答by GSerg

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 Addmethod).

除此之外，是的，您可以对集合中的项目进行排序。
您需要采用 Internet 上可用的任何排序算法（您基本上可以使用任何语言在 google 上搜索实现）并在发生交换的地方进行微小更改（其他更改是不必要的，因为可以使用索引访问 vba 集合，如数组）。要交换集合中的两个项目，您需要将它们都从集合中移除并将它们插回正确的位置（使用该方法的第三个或第四个参数Add）。

回答by Russ Cam

There is no native sort for the Collectionin VBA, but since you can access items in the collection via index, you can implement a sorting algorithm to go through the collection and sort into a new collection.

CollectionVBA 中没有原生排序，但是由于您可以通过索引访问集合中的项目，您可以实现排序算法来遍历集合并排序到新集合中。

Here's a HeapSort algorithm implementationfor VBA/VB 6.

这是VBA/VB 6的HeapSort 算法实现。

Here's what appears to be a BubbleSort algorithm implementationfor VBA/VB6.

这似乎是VBA/VB6的BubbleSort 算法实现。

回答by Anonymous Coward

If your collection doesn't contain objects and you only need to sort ascending, you might find this easier to understand:

如果您的集合不包含对象并且您只需要升序排序，您可能会发现这更容易理解：

Sub Sort(ByVal C As Collection)
Dim I As Long, J As Long
For I = 1 To C.Count - 1
    For J = I + 1 To C.Count
        If C(I) > C(J) Then Swap C, I, J
    Next
Next
End Sub

'Take good care that J > I
Sub Swap(ByVal C As Collection, ByVal I As Long, ByVal J As Long)
C.Add C(J), , , I
C.Add C(I), , , J + 1
C.Remove I
C.Remove J
End Sub

I hacked this up in minutes, so this may not be the best bubble sort, but it should be easy to understand, and hence easy to modify for your own purposes.

我在几分钟内解决了这个问题，所以这可能不是最好的冒泡排序，但它应该很容易理解，因此很容易根据自己的目的进行修改。

回答by Vityata

This is my implementation of BubbleSort:

这是我对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

回答by workingobrien

This code snippet works well, but it is in java.

这段代码片段运行良好，但它是在 java 中的。

To translate it you could do it like this:

要翻译它，您可以这样做：

 Function CollectionSort(ByRef oCollection As Collection) As Long
Dim smTempItem1 As SeriesManager, smTempItem2 As SeriesManager
Dim i As Integer, j As Integer
i = 1
j = 1

On Error GoTo ErrFailed
Dim swapped As Boolean
swapped = True
Do While (swapped)
    swapped = False
    j = j + 1

    For i = 1 To oCollection.Count - 1 - j
        Set smTempItem1 = oCollection.Item(i)
        Set smTempItem2 = oCollection.Item(i + 1)

        If smTempItem1.Diff > smTempItem2.Diff Then
            oCollection.Add smTempItem2, , i
            oCollection.Add smTempItem1, , i + 1

            oCollection.Remove i + 1
            oCollection.Remove i + 2

            swapped = True
        End If
    Next
Loop
Exit Function

ErrFailed:
     Debug.Print "Error with CollectionSort: " & Err.Description
     CollectionSort = Err.Number
     On Error GoTo 0
End Function

SeriesManager is just a class that stores the difference between two values. It can really be any number value you want to sort on. This by default sorts in ascending order.

SeriesManager 只是一个存储两个值之间差异的类。它实际上可以是您想要排序的任何数值。默认情况下按升序排序。

I had difficulty sorting a collection in vba without making a custom class.

在不创建自定义类的情况下，我很难在 vba 中对集合进行排序。

回答by igorsp7

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

这是 QuickSort 算法的 VBA 实现，它通常是 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 ISortableObjectinterface, which must be defined in your VBA project. To do that, add a class module called ISortableObject with the following code:

集合中存储的对象必须实现ISortableObject接口，该接口必须在您的 VBA 项目中定义。为此，请使用以下代码添加名为 ISortableObject 的类模块：

Public Property Get vSortKey() As Variant
End Property