Кто-нибудь знает, как сортировать коллекцию в VBA?
Как сортировать коллекцию?
Ответ 1
Код ниже из этого поста использует пузырьковую сортировку
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
Ответ 2
Поздно к игре... вот реализация алгоритма MergeSort в VBA для массивов и коллекций. Я протестировал производительность этой реализации против реализации BubbleSort в принятом ответе, используя случайно сгенерированные строки. В приведенной ниже таблице приведены результаты, т.е. что вы не должны использовать BubbleSort для сортировки коллекции VBA.
Вы можете загрузить исходный код из моего репозитория 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://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
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
Если IVariantComparator не предоставляется IVariantComparator, то предполагается естественное упорядочение. Однако, если вам нужно определить другой порядок сортировки (например, обратный) или если вы хотите сортировать пользовательские объекты, вы можете реализовать интерфейс IVariantComparator. Например, для сортировки в обратном порядке просто создайте класс с именем CReverseComparator со следующим кодом:
Класс 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/ p >
Ответ 3
Вы можете использовать ListView. Хотя это объект пользовательского интерфейса, вы можете использовать его функциональность. Он поддерживает сортировку. Вы можете хранить данные в 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 Text
lv.SortOrder = lvwAscending
lv.Sorted = True
MsgBox lv.ListItems(1) ' returns "A"
MsgBox lv.ListItems(2) ' returns "B"
Ответ 4
Коллекция - довольно неправильный объект для сортировки.
Сама точка коллекции - обеспечить очень быстрый доступ к определенному элементу, идентифицированному ключом. Как элементы хранятся внутри, должны быть неактуальными.
Возможно, вы захотите использовать массивы вместо коллекций, если вам действительно нужна сортировка.
Кроме этого, да, вы можете сортировать элементы в коллекции.
Вам необходимо использовать любой алгоритм сортировки, доступный в Интернете (вы можете использовать Google в целом на любом языке) и внести незначительные изменения там, где происходит своп (другие изменения не нужны, поскольку коллекции vba, например массивы, могут быть доступны с индексами). Чтобы поменять два элемента в коллекции, вам необходимо удалить их из коллекции и вставить их обратно в правильные позиции (используя третий или четвертый параметр метода Add).
Ответ 5
В VBA нет собственного сортировки для Collection, но поскольку вы можете обращаться к элементам коллекции через индекс, вы можете реализовать алгоритм сортировки, чтобы просмотреть коллекцию и отсортировать ее в новой коллекции.
Здесь реализация алгоритма HeapSort для VBA/VB 6.
Вот что выглядит как реализация алгоритма BubbleSort для VBA/VB6.
Ответ 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
Я взломал это за считанные минуты, поэтому это может быть не лучший выбор пузырьков, но его нужно легко понять и, следовательно, легко изменить для своих целей.
Ответ 7
Этот фрагмент кода работает хорошо, но он в 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 без создания пользовательского класса.
Ответ 8
Это моя реализация 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
Он берет коллекцию по ссылке, поэтому может легко возвращать ее как функцию и имеет необязательный параметр для сортировки по возрастанию и по убыванию. Сортировка возвращает это в ближайшем окне:
2342
2z
alpha
baba
beta
hvarchiloto
na
stackoveflow
ti
vityata
zuzan
zuzana
--------------------
zuzana
zuzan
vityata
ti
stackoveflow
na
hvarchiloto
beta
baba
alpha
2z
2342
Ответ 9
Это реализация алгоритма 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
Объекты, хранящиеся в коллекции, должны реализовывать интерфейс ISortableObject, который должен быть определен в вашем проекте VBA. Для этого добавьте модуль класса ISortableObject со следующим кодом:
Public Property Get vSortKey() As Variant
End Property