Сортировка Userform ListBox [дубликат]

Если ваша коллекция не содержит объектов, и вам нужно только сортировать по возрастанию, вам может быть проще понять это:

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

Я взломал это за считанные минуты, так что это может быть не лучший вид пузырьков, но он должен быть легко понят и, следовательно, легко модифицироваться для ваших целей.

Поздно к игре ... вот реализация алгоритма 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 к методам sort, то предполагается естественное упорядочение. Однако, если вам нужно определить другой порядок сортировки (например, обратный) или если вы хотите отсортировать пользовательские объекты, вы можете реализовать интерфейс 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/

Вы можете использовать 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's Text
lv.SortOrder = lvwAscending
lv.Sorted = True
MsgBox lv.ListItems(1)    ' returns "A"
MsgBox lv.ListItems(2)    ' returns "B"

Коллекция - довольно неправильный объект для сортировки.

Сама точка коллекции - обеспечить очень быстрый доступ к определенному элементу, идентифицированному ключом.

Вы можете захотеть использовать массивы вместо коллекций, если вам действительно нужна сортировка.

Кроме этого, да, вы могут сортировать элементы в коллекции. Вам необходимо использовать любой алгоритм сортировки, доступный в Интернете (вы можете использовать Google в целом на любом языке) и внести незначительные изменения там, где происходит своп (другие изменения не нужны, поскольку коллекции vba, например массивы, могут быть доступны с индексами). Чтобы поменять два элемента в коллекции, вам необходимо удалить их из коллекции и вставить их обратно в правильные позиции (используя третий или четвертый параметр метода Add).

Это реализация 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

Этот фрагмент кода работает хорошо, но он находится в 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 нет родной сортировки для Collection, но поскольку вы можете обращаться к элементам коллекции через индекс, вы можете реализовать алгоритм сортировки, чтобы просмотреть коллекцию и отсортировать ее в новую коллекцию.

Вот реализация алгоритма HeapSort для VBA / VB 6.

Вот что представляет собой реализация алгоритма BubbleSort для VBA / VB6.

Это моя реализация 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

Он берет коллекцию по ссылке, поэтому она может легко вернуть ее как функцию и имеет необязательный параметр для Сортировка по возрастанию и убыванию. Сортировка возвращает это в ближайшем окне:

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