有人知道如何在VBA中对集合进行排序吗?
有人知道如何在VBA中对集合进行排序吗?
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/进行视觉对比。copyOf()
、length()
和swap()
。以当前形式无法进行测试;答案中是否应该包含另一个模块? - sigil以下代码取自这篇文章,使用了冒泡排序
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
您可以使用 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"
mscomctl.ocx
的引用。 - cxw在排序方面,集合不是一个很合适的对象。
集合的主要目的是提供通过键快速访问特定元素。内部如何存储项目应是不相关的。
如果你需要排序,可以考虑使用数组代替集合。
除此之外,是的,你可以对集合中的项目进行排序。
你需要使用互联网上可用的任何排序算法(你可以在基本上任何语言中搜索实现),并在交换发生时进行微小修改(其他更改是不必要的,因为 VBA 集合和数组一样可以使用索引访问)。为了交换集合中的两个项,你需要将它们都从集合中删除,并在正确的位置插入它们回来(使用Add
方法的第三或第四个参数)。
.add
用于动态添加元素。 - James MertzFunction foo() As Long()
返回一个 Long
数组。你可能在想 VB5。 - GSerg在VBA中,Collection
没有本地排序功能,但由于可以通过索引访问集合中的项,因此可以实现排序算法来遍历集合并将其排序到新的集合中。
这是VBA/VB 6的HeapSort算法实现。
这似乎是VBA/VB6的BubbleSort算法实现。
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
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
这段代码片段运行良好,但它是用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中对集合进行排序,但没有使用自定义类很困难。
这是一个使用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
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