Le code ci-dessous de cet article utilise une sorte de bulle
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
En retard au jeu… voici une implémentation de l'algorithme MergeSort en VBA pour les tableaux et les collections. J'ai testé les performances de cette implémentation par rapport à celle de BubbleSort dans la réponse acceptée à l'aide de chaînes générées de manière aléatoire. Le tableau ci-dessous résume les résultats, c’est-à-dire que vous ne devez pas utiliser BubbleSort pour trier une collection VBA .
Vous pouvez télécharger le code source à partir de mon GitHub Repository ou simplement copier/coller le code source ci-dessous dans les modules appropriés.
Pour une collection col, appelez simplement Collections.sort col.
Module Collections
'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
Module de tableaux
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
Classe 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
Si aucun IVariantComparator n'est fourni aux méthodes sort, l'ordre naturel est supposé. Toutefois, si vous devez définir un ordre de tri différent (par exemple, inverser) ou si vous souhaitez trier des objets personnalisés, vous pouvez implémenter l'interface IVariantComparator. Par exemple, pour trier dans l'ordre inverse, créez simplement une classe appelée CReverseComparator avec le code suivant:
Classe CReverseComparator
Option Explicit
Implements IVariantComparator
Public Function IVariantComparator_compare(v1 As Variant, v2 As Variant) As Long
IVariantComparator_compare = v2-v1
End Function
Appelez ensuite la fonction de tri comme suit: Collections.sort col, New CReverseComparator
Matériel bonus: Pour une comparaison visuelle des performances de différents algorithmes de tri, consultez https://www.toptal.com/developers/sorting-algorithms/
Vous pouvez utiliser une ListView . Bien qu'il s'agisse d'un objet d'interface utilisateur, vous pouvez utiliser ses fonctionnalités. Il prend en charge le tri. Vous pouvez stocker des données dans Listview.ListItems et ensuite trier comme ceci:
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"
La collecte est un objet plutôt erroné pour le tri.
Le but même d'une collection est de fournir un accès très rapide à un certain élément identifié par une clé. La manière dont les éléments sont stockés en interne ne devrait pas être pertinente.
Vous pouvez envisager d'utiliser des tableaux plutôt que des collections si vous avez réellement besoin de trier.
En dehors de cela, vous pouvez trier les éléments d'une collection.
Vous devez utiliser n'importe quel algorithme de tri disponible sur Internet (vous pouvez utiliser Google inplementations dans pratiquement toutes les langues) et effectuer une modification mineure lors d’un échange (d’autres modifications ne sont pas nécessaires, car les collections vba, comme les tableaux, sont accessibles avec des index. ). Pour échanger deux éléments d'une collection, vous devez les supprimer de la collection et les réinsérer aux bons emplacements (à l'aide du troisième ou du quatrième paramètre de la méthode Add).
Il n'existe pas de tri natif pour Collection dans VBA, mais comme vous pouvez accéder aux éléments de la collection via index, vous pouvez implémenter un algorithme de tri pour parcourir la collection et trier dans une nouvelle collection.
Voici une implémentation de l'algorithme HeapSort pour VBA/VB 6.
Voici ce qui semble être une implémentation de l'algorithme BubbleSort pour VBA/VB6.
Si votre collection ne contient pas d'objets et qu'il vous suffit de trier par ordre croissant, vous trouverez peut-être cela plus facile à comprendre:
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
Je l'ai piraté en quelques minutes, alors ce n'est peut-être pas le meilleur type de bulle, mais il devrait être facile à comprendre, et donc facile à modifier pour vos propres besoins.
Cet extrait de code fonctionne bien, mais il est en Java.
Pour le traduire, vous pouvez le faire comme ceci:
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 est simplement une classe qui stocke la différence entre deux valeurs. Il peut s'agir de n'importe quelle valeur numérique que vous souhaitez trier. Cela trie par défaut dans l'ordre croissant.
J'ai eu du mal à trier une collection dans vba sans créer de classe personnalisée.
Ceci est mon implémentation de BubbleSort :
Option Explicit
Public Function fnVarBubbleSort(ByRef colInput As Collection, Optional bAsc = True) As Collection
Dim varTemp As Variant
Dim lngCounter As Long
Dim lngCounter2 As Long
For lngCounter = 1 To colInput.Count - 1
For lngCounter2 = lngCounter + 1 To colInput.Count
Select Case bAsc
Case True:
If colInput(lngCounter) > colInput(lngCounter2) Then
varTemp = colInput(lngCounter2)
colInput.Remove lngCounter2
colInput.Add varTemp, varTemp, lngCounter
End If
Case False:
If colInput(lngCounter) < colInput(lngCounter2) Then
varTemp = colInput(lngCounter2)
colInput.Remove lngCounter2
colInput.Add varTemp, varTemp, lngCounter
End If
End Select
Next lngCounter2
Next lngCounter
Set fnVarBubbleSort = colInput
End Function
Public Sub TestMe()
Dim colCollection As New Collection
Dim varElement As Variant
colCollection.Add "2342"
colCollection.Add "vityata"
colCollection.Add "na"
colCollection.Add "baba"
colCollection.Add "ti"
colCollection.Add "hvarchiloto"
colCollection.Add "stackoveflow"
colCollection.Add "beta"
colCollection.Add "zuzana"
colCollection.Add "zuzan"
colCollection.Add "2z"
colCollection.Add "alpha"
Set colCollection = fnVarBubbleSort(colCollection)
For Each varElement In colCollection
Debug.Print varElement
Next varElement
Debug.Print "--------------------"
Set colCollection = fnVarBubbleSort(colCollection, False)
For Each varElement In colCollection
Debug.Print varElement
Next varElement
End Sub
Il prend la collection par référence, il peut donc facilement la renvoyer sous forme de fonction et possède un paramètre facultatif pour le tri croissant et décroissant .
2342
2z
alpha
baba
beta
hvarchiloto
na
stackoveflow
ti
vityata
zuzan
zuzana
--------------------
zuzana
zuzan
vityata
ti
stackoveflow
na
hvarchiloto
beta
baba
alpha
2z
2342
Ceci est une implémentation VBA de l’algorithme QuickSort, qui est souvent une meilleure alternative à 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
Les objets stockés dans la collection doivent implémenter l'interface ISortableObject, qui doit être définie dans votre projet VBA. Pour ce faire, ajoutez un module de classe appelé ISortableObject avec le code suivant:
Public Property Get vSortKey() As Variant
End Property