如何对集合进行排序？

Question

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

- Alex Gordon

---

首先，您应该定义收集品中包含哪些内容以及您希望如何对其进行排序。否则，所有这一切都只是猜测。 - Daniel Dušek

Answer 1

这是一个关于在 VBA 中实现数组和集合的归并排序算法的内容。我使用随机生成的字符串测试了这个实现的性能，并将其与接受答案中的冒泡排序实现进行了比较。下面的图表总结了结果，即不应该使用冒泡排序来对 VBA 集合进行排序。请注意保留 HTML 标签。

您可以从我的 GitHub 代码库 下载源代码，或者只需将下面的源代码复制/粘贴到适当的模块中即可。

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

'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

数组模块

    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://dev59.com/IHA75IYBdhLWcg3wipmH#3245183
            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类

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

如果在sort方法中没有提供IVariantComparator，则假定采用自然排序。然而，如果需要定义不同的排序顺序（例如反向排序）或者需要对自定义对象进行排序，则可以实现IVariantComparator接口。例如，要进行反向排序，只需创建名为CReverseComparator的类，并使用以下代码：

Option Explicit

Implements IVariantComparator

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

请按照以下方式调用排序函数：Collections.sort col, New CReverseComparator 额外材料: 若要比较不同排序算法的性能，请查看https://www.toptal.com/developers/sorting-algorithms/进行视觉对比。

- Austin

---

这在VBA中对我来说很困难，因为我不是真正的程序员，所以需要付出巨大的努力才能使其工作。最终，我使用了cpearson的数组排序，因为使用砖块制造工厂会更容易，而Collections.ToArray函数会添加一个令人讨厌的额外项，因为它会将a(0到count)重新定义为a(0到count-1)，而我的数组从0开始，而我的集合从1开始。 - Henrietta Martingale

看起来是很棒的信息和代码。对于不熟悉VBA的人而言，放置位置不是非常清晰。“只需将下面的源代码复制/粘贴到相应的模块中。”这些模块在哪里？ - Joe McGrath

这里有很多函数没有在模块中定义，也不是标准的VBA函数，例如copyOf()、length()和swap()。以当前形式无法进行测试；答案中是否应该包含另一个模块？ - sigil

我甚至在GitHub存储库中找不到这些函数。例如，Readme文件中提到了Arrays.copyOf，但未包含在Arrays.bas中。VBA-Utilities.xlam中的代码也无法编译，因为缺少方法。 - Jörg Brenninkmeyer

Answer 2

以下代码取自这篇文章，使用了冒泡排序

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

- Dick Kusleika

---

谢谢 - 我只需要将vTemp更改为Object类型，以便对对象集合进行排序。 - Ron Rosenfeld

可以不要推荐冒泡排序吗？它是一个非常糟糕的算法。 - Johan

你可以省略 'key' 参数，只需加入一个额外的逗号即可。 - bmende

此外，如果您尝试缩短并输入cFruit.Remove cFruit(j)，则会出现运行时错误。 - bmende

@Johan 同意...我在下面添加了一个归并排序的实现 - Austin

Answer 3

您可以使用 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"

- ameisenmann

---

这真是太聪明了！我刚试过了，效果非常好。如果你想在同一个表格中保留多个排序方式，还可以按特定子项目进行排序。别忘了添加对 mscomctl.ocx 的引用。 - cxw

C:\Windows\SysWOW64\mscomctl.ocx 是 Microsoft Common Controls。这太棒了，令人惊讶的是它可以在没有表单的情况下运行。 - S Meaden

另一个解决方法：将集合复制到电子表格上的范围内，对该范围进行排序，然后将其复制回来。 - ilya

这可能有效，但不建议使用。当使用VBA集合并将其暂时克隆/复制到ListView中时，利用其排序功能，然后将排序后的项目放回到集合（数组）中是繁琐的编程过程。最好使用通用排序算法，如@Austin答案中提到的那样。虽然这也涉及来回复制操作。 - Youp Bernoulli

Answer 4

在排序方面，集合不是一个很合适的对象。

集合的主要目的是提供通过键快速访问特定元素。内部如何存储项目应是不相关的。

如果你需要排序，可以考虑使用数组代替集合。

---

除此之外，是的，你可以对集合中的项目进行排序。
你需要使用互联网上可用的任何排序算法（你可以在基本上任何语言中搜索实现），并在交换发生时进行微小修改（其他更改是不必要的，因为 VBA 集合和数组一样可以使用索引访问）。为了交换集合中的两个项，你需要将它们都从集合中删除，并在正确的位置插入它们回来（使用Add方法的第三或第四个参数）。

- GSerg

---

在VBA中使用数组时，没有.add用于动态添加元素。 - James Mertz

我理解，但是你建议使用数组而不是集合，这样就不能很容易地动态添加到数组中。 - James Mertz

@GSerg：抱歉，我犯了一个错误，应该是“...你不能将它们用作返回值”。 - Dynamicbyte

@Dynamicbyte 是的，你可以。Function foo() As Long() 返回一个 Long 数组。你可能在想 VB5。 - GSerg

@technoman23 在VBA中没有ArrayList，而且我认为从.Net中引入一个ArrayList并不值得这样做的开销。 - GSerg

Answer 5

在VBA中，Collection没有本地排序功能，但由于可以通过索引访问集合中的项，因此可以实现排序算法来遍历集合并将其排序到新的集合中。

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

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

- Russ Cam

Answer 6

如果您的集合不包含任何对象，并且只需要进行升序排序，您可能会发现以下方式更易于理解：

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

我在几分钟内匆忙写出了这个程序，所以这可能不是最好的冒泡排序算法，但它应该很容易理解，因此对于您自己的目的来说也很容易修改。

- Anonymous Coward

Answer 7

这是我对 冒泡排序 的实现：

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

它通过引用收集数据，因此可以轻松地将其作为函数返回，并具有可选参数进行升序和降序排序。 排序结果将在即时窗口中返回：

2342
2z
alpha
baba
beta
hvarchiloto
na
stackoveflow
ti
vityata
zuzan
zuzana
--------------------
zuzana
zuzan
vityata
ti
stackoveflow
na
hvarchiloto
beta
baba
alpha
2z
2342

- Vityata

Answer 8

这段代码片段运行良好，但它是用Java编写的。

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

 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是一个仅用于存储两个值之间差异的类。它可以是任何您想要进行排序的数字值。默认情况下，它按升序排序。

我曾尝试在vba中对集合进行排序，但没有使用自定义类很困难。

- workingobrien

Answer 9

这是一个使用VBA实现的QuickSort算法，通常被认为是比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

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

Public Property Get vSortKey() As Variant
End Property

- igorsp7

Answer 10

我想对igorsp7的快速排序做一些深入研究。

如果你不想为了排序而使用特殊接口，你可以使用CallByName函数。

Public Sub QuickSortCollection(colSortable As Object, nameOfSortingProperty As String, Optional bSortAscending As Boolean = True, Optional iLow1, Optional iHigh1)
Dim obj1 As Object
Dim obj2 As Object
Dim clsSortable As Object
Dim clsSortable2 As Object
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 = CallByName(clsSortable, nameOfSortingProperty, VbGet)

'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 CallByName(clsSortable, nameOfSortingProperty, VbGet) < 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 CallByName(clsSortable2, nameOfSortingProperty, VbGet) > 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 CallByName(clsSortable, nameOfSortingProperty, VbGet) > 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 CallByName(clsSortable2, nameOfSortingProperty, VbGet) < 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 CallByName(clsSortable, nameOfSortingProperty, VbGet) <> CallByName(clsSortable2, nameOfSortingProperty, VbGet) 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 Call QuickSortCollection(colSortable, nameOfSortingProperty, bSortAscending, iLow1, iHigh2)

'Recurse to sort the upper half of the extremes
If iLow2 < iHigh1 Then Call QuickSortCollection(colSortable, nameOfSortingProperty, bSortAscending, iLow2, iHigh1)

PtrExit:
End Sub

我已将colSortable更改为对象，因为我正在使用很多自定义类型集合。

- lumenn