Sorting Collections

[Benzadeus]

I'd like to know if you have a neater way of sorting collections that contain only numbers.

[VBA]Option Explicit
Option Base 1
Sub TestSorting()
Dim mycol As Collection
Dim n As Long

Set mycol = New Collection
mycol.Add 25, "25"
mycol.Add 83, "83"
mycol.Add 12, "12"
mycol.Add 14, "14"
mycol.Add 10, "10"
Debug.Print vbCrLf
For n = 1 To mycol.Count
Debug.Print mycol(n),
Next n
Set mycol = SortCollection(mycol)
Debug.Print
For n = 1 To mycol.Count
Debug.Print mycol(n),
Next n
Set mycol = Nothing
End Sub
Function SortCollection(col As Collection) As Collection

Dim n As Integer
Dim dblSmall As Double
Dim dblArray() As Double

Set SortCollection = New Collection

ReDim dblArray(col.Count)

For n = 1 To col.Count
dblArray(n) = col(n)
Next n
For n = 1 To col.Count
dblSmall = WorksheetFunction.Small(dblArray, n)
SortCollection.Add dblSmall, CStr(dblSmall)
Next n

Set col = Nothing

End Function
[/VBA]

In my approach, I used an array to get the collection's values and used worksheet function small to get the desired numbers.

[Bob Phillips]

There are many wasy you could do it, make it more generic, but I think you would invariably dump it into an array and sort the array by whatever means, so if your dataset is not huge, seems as good as any.

[mikerickson]

You could use a function like this, but it would be best if you could use the technique when originaly filling the collection, so it starts off being sorted.
[VBA]Sub test()
Dim mycol As Collection

Set mycol = New Collection
mycol.Add 25, "25"
mycol.Add 83, "83"
mycol.Add 12, "12"
mycol.Add 14, "14"
mycol.Add 10, "10"
MsgBox Join(SortCollection(mycol))
'I don't know if Window's Join works on collections, but my emulator for Mac does.
End Sub

Function SortCollection(aColl As Collection) As Collection
Dim i As Long
Dim SortedCollection As New Collection
Dim oneVal As Variant

For Each oneVal In aColl
If SortedCollection.Count = 0 Then
SortedCollection.Add Item:=oneVal, key:=CStr(oneVal)
Else
For i = 1 To SortedCollection.Count
If oneVal < SortedCollection(i) Then
On Error Resume Next
SortedCollection.Add Item:=oneVal, key:=CStr(oneVal), before:=i
On Error GoTo 0
Exit For
End If
Next i
On Error Resume Next
SortedCollection.Add Item:=oneVal, key:=CStr(oneVal)
On Error GoTo 0
End If
Next oneVal
Set SortCollection = SortedCollection
Set SortedCollection = Nothing
End Function[/VBA]

[Benzadeus]

Join didn't work with collections on my Excel 2003.

Also, I forgot to tel that in my new collection would retain only unique entries.

[GTO]

Join didn't work with collections on my Excel 2003.

Also, I forgot to tel that in my new collection would retain only unique entries.

Hi Benzadeus,

As Mike mentioned, he wasn't sure about Windows. Join didn't work for me either, and in fact, I am unknowing as to how to dump a Collection into an array at all. AFAIK, you would need to iterate the vals into an array. (Mike/Someone: please correct me if wrong).

As to unique vals, I may be feeling silly momentarily, but you do realie that as long as you use the val for the val and key, you cannot help but have a unique vals collection, right?

Sorry if I misunderstood your post and am pointing out something known...

Mark

[mikerickson]

Thanks guys for the Join info.

Dumping a collection into an array would involve iteration, AFAIK.

Whenever the key is a function of the items, as in this case, all the items in a collection are unique.

This is an imporoved version of the sort.
[VBA]Function SortCollection(aColl As Collection, Optional Descending As Boolean) As Collection
Dim i As Long
Dim SortedCollection As New Collection
Dim oneVal As Variant

For Each oneVal In aColl
If SortedCollection.Count = 0 Then
SortedCollection.Add Item:=oneVal, key:=CStr(oneVal)
Else
For i = 1 To SortedCollection.Count
If (oneVal < SortedCollection(i)) Xor Descending Then
On Error Resume Next
SortedCollection.Add Item:=oneVal, key:=CStr(oneVal), before:=i
On Error GoTo 0
GoTo NextVal
End If
Next i
On Error Resume Next
SortedCollection.Add Item:=oneVal, key:=CStr(oneVal)
On Error GoTo 0
NextVal:
End If
Next oneVal

Set SortCollection = SortedCollection
Set SortedCollection = Nothing
End Function

Sub test()
Dim mycol As Collection

Set mycol = New Collection
mycol.Add 25, "25"
mycol.Add 83, "83"
mycol.Add 12, "12"
mycol.Add 14, "14"
mycol.Add 10, "10"

MsgBox rrayStr(SortCollection(mycol))

MsgBox rrayStr(SortCollection(mycol, True))

End Sub

Function rrayStr(ByVal inputRRay As Variant, Optional Delimiter As String)
Dim xVal As Variant
If IsEmpty(inputRRay) Then Exit Function
If Delimiter = vbNullString Then Delimiter = " "
For Each xVal In inputRRay
rrayStr = rrayStr & Delimiter & xVal
Next xVal
rrayStr = Mid(rrayStr, Len(Delimiter) + 1)
End Function[/VBA]

[Benzadeus]

I agree with post #5.

Thanks for example in post #6, Mike, it is very good.

[Paul_Hossler]

I knew I'd seen something about sorting collections before

http://www.source-code.biz/snippets/vbasic/6.htm

How to sort a collection in Visual Basic using HeapSort
HeapSort is a simple and relatively fast sorting algorithm. The routine below uses the HeapSort algorithm to sort a VB collection object.

[vba]
Option Explicit

'--- Sample for using the SortCollection function -----------------------
Public Sub Sample1()
Dim c As New Collection
c.Add "Pear"
c.Add "Apple"
c.Add "Cherry"
c.Add "Prune"
c.Add "Peach"
Dim c2 As Collection
Set c2 = SortCollection(c)
Dim s
For Each s In c2
Debug.Print s
Next
End Sub

' This routine uses the "heap sort" algorithm to sort a VB collection.
' It returns the sorted collection.
' Author: Christian d'Heureuse (www.source-code.biz)
Public Function SortCollection(ByVal c As Collection) As Collection
Dim n As Long

n = c.Count
If n = 0 Then
Set SortCollection = New Collection
Exit Function
End If
' allocate index array
ReDim Index(0 To n - 1) As Long

Dim i As Long, m As Long

' fill index array
For i = 0 To n - 1
Index(i) = i + 1
Next

' generate ordered heap
For i = n \ 2 - 1 To 0 Step -1
Heapify c, Index, i, n
Next

' sort the index array
For m = n To 2 Step -1
' move highest element to top
Exchange Index, 0, m - 1
Heapify c, Index, 0, m - 1
Next

Dim c2 As New Collection
' fill output collection
For i = 0 To n - 1
c2.Add c.Item(Index(i))
Next

Set SortCollection = c2
End Function
Private Sub Heapify(ByVal c As Collection, Index() As Long, ByVal i1 As Long, ByVal n As Long)
' Heap order rule: a[i] >= a[2*i+1] and a[i] >= a[2*i+2]
Dim nDiv2 As Long: nDiv2 = n \ 2
Dim i As Long: i = i1

Do While i < nDiv2
Dim k As Long
k = 2 * i + 1
If k + 1 < n Then
If c.Item(Index(k)) < c.Item(Index(k + 1)) Then k = k + 1
End If

If c.Item(Index(i)) >= c.Item(Index(k)) Then Exit Do

Exchange Index, i, k

i = k

Loop
End Sub
Private Sub Exchange(Index() As Long, ByVal i As Long, ByVal j As Long)
Dim Temp As Long: Temp = Index(i)

Index(i) = Index(j)
Index(j) = Temp
End Sub
[/vba]

Maybe this will help. You might have to edit the variables, etc. depending on your data.

Paul