以下からのコード 投稿はバブルソートを使用
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
ゲームに遅れて...ここに、VBAでの配列とコレクションの両方に対する MergeSortアルゴリズム の実装があります。ランダムに生成された文字列を使用して、受け入れられた回答のBubbleSort実装に対するこの実装のパフォーマンスをテストしました。以下のグラフは、結果を要約しています。つまり、 VBAコレクションの並べ替えにBubbleSortを使用しないでください です。
GitHub Repository からソースコードをダウンロードするか、以下のソースコードをコピーして適切なモジュールに貼り付けます。
コレクション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/ソートアルゴリズム/
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"
コレクションは、ソートのためのかなり間違ったオブジェクトです。
コレクションのまさにポイントは、キーによって識別される特定の要素への非常に高速なアクセスを提供することです。アイテムが内部にどのように保存されるかは無関係です。
実際に並べ替えが必要な場合は、コレクションの代わりに配列の使用を検討してください。
それ以外にも、はい、コレクション内のアイテムを並べ替えることができます。
。インデックス付き）。コレクション内の2つのアイテムを交換するには、コレクションからそれらを削除し、正しい位置に挿入し直す必要があります（Addメソッドの3番目または4番目のパラメーターを使用）。
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
私はこれを数分でハックしたので、これは最高のバブルソートではないかもしれませんが、理解しやすく、したがって自分の目的に合わせて簡単に修正できるはずです。
このコードスニペットはうまく機能しますが、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は、2つの値の差を保存する単なるクラスです。実際には、ソートしたい任意の数値にすることができます。これはデフォルトで昇順でソートされます。
カスタムクラスを作成しないと、vbaでコレクションを並べ替えることができませんでした。
これは 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
これは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