Sort any type of collection in VBA 2

[1DMF]

Hi,

I seem unable to find any VBA collection or even a scripting dictionary that has an in-built sort functionality.

Is this correct?

I'm currently using this bubble sort code...

Public Function sortCol(ByVal cCol As Collection) As Collection

   Dim i As Long
   Dim x As Long
   Dim vOld As Variant

   For i = 1 To cCol.Count - 1
        For x = i + 1 To cCol.Count
            If cCol(i) > cCol(x) Then
               vOld = cCol(x)
               cCol.Remove x                              
               cCol.Add vOld, vOld, i
            End If
        Next x
    Next i
    
   Set sortCol = cCol
End Function

Which I am having to use to populate a list box on a from with the content of a directory like so...

Private Sub Form_Open(Cancel As Integer)

    Dim sPath As String
    Dim sFile As String
    Dim vCode As Variant
    Dim cCol1 As New Collection
    Dim cCol2 As New Collection
    
    ' remove current list items
    Do While Me.Pre_Approved.ListCount > 0
        Me.Pre_Approved.RemoveItem (0)
    Loop
    
    ' get files in directory
    sPath = cDrive & "Members Database\AccessTemplates\Financial_Promotions\"
    sFile = Dir(sPath & "*.*", vbDirectory)
    
    ' loop and add to collection
    Do While sFile <> ""
        If sFile <> "." And sFile <> ".." Then
            vCode = Split(sFile, "-")
            cCol1.Add left(vCode(UBound(vCode)), 7), left(vCode(UBound(vCode)), 7)
            cCol2.Add (sPath & sFile), left(vCode(UBound(vCode)), 7)
        End If
        sFile = Dir
    Loop

    ' sort collection
    Set cCol1 = sortCol(cCol1)

    ' add to listbox and remove from collection
    Do While cCol1.Count > 0
        Me.Pre_Approved.addItem Item:=Chr(34) & cCol1.Item(1) & Chr(34) & Chr(59) & Chr(34) & cCol2.Item(cCol1(1)) & Chr(34)
        cCol1.Remove 1
    Loop
    
    ' clear collections
    Set cCol1 = Nothing
    Set cCol2 = Nothing
    
End Sub

This seems ridiculously convoluted just to be able to have a sorted collection... so is there a better way?

Thanks,
1DMF.



"In complete darkness we are all the same, it is only our knowledge and wisdom that separates us, don't let your eyes deceive you."

"If a shortcut was meant to be easy, it wouldn't be a shortcut, it would be the way!"
Free Electronic Dance Music

 

[1DMF]

Yeah, probably will use it.

I was intrigued with having access to class objects that offered this natively though.

You may want to note that this sorts by key and not by item

Yes I was aware, and for my use that was fine...

    ' loop and add to collection
    Do While sFile <> ""
        If sFile <> "." And sFile <> ".." Then
            vCode = Split(sFile, "-")
            Call oCol.Add(left(vCode(UBound(vCode)), 7), (sPath & sFile))
        End If
        sFile = Dir
    Loop

Though typically (well as I expected and stated) it crashed on a user as they didn't have .NET4, so just spent 20 minutes installing the darn thing!

And why does Access throw weird unrelated errors when a reference is missing, it errored saying that a query using Format(d,"Short Date") was invalid!

"In complete darkness we are all the same, it is only our knowledge and wisdom that separates us, don't let your eyes deceive you."

"If a shortcut was meant to be easy, it wouldn't be a shortcut, it would be the way!"
Free Electronic Dance Music

 

[MajP]

Like I said if you roll your own you can then add or modify to fit your needs.
You could modify this to be more like the sorted list, where you sort on the key and then you could do other objects and not just value types. Here I added a sortorder property. So you can define it as sorted descending and then it will add in descending.

Option Compare Database
Option Explicit

Private mCollection As New Collection
Private mSortOrder As SortOrder

Public Enum SortOrder
  Asc = 0
  Desc = 1
End Enum
Public Property Get count() As Long
  count = mCollection.count
End Property
Public Function Add(Item As Variant, Optional Key As String = "") As Variant
   Dim i As Long
   Dim CollectionCount As Long
   If Not TypeOf Item Is Object  Then
     Add = Item
   Else
     MsgBox "Only supports value types"
     Exit Function
   End If
   CollectionCount = mCollection.count
   If CollectionCount = 0 Then
     'Single Item
     If Key <> "" Then
      mCollection.Add Item, Key
     Else
      mCollection.Add Item
     End If
   'Handle ascending add
   ElseIf Me.SortOrder = Asc Then
      If mCollection.Item(CollectionCount) <= Item Then
        'Greater Than last item and ascending
         If Key <> "" Then
            mCollection.Add Item, Key
          Else
            mCollection.Add Item
          End If
      Else
        For i = 1 To CollectionCount
        'could add a binary search here can do that later
           If mCollection.Item(i) > Item Then
             If Key <> "" Then
               mCollection.Add Item, Key, i
             Else
               mCollection.Add Item, , i
             End If
             Exit For
           End If
         Next i
      End If
   'Handle Descending add
 
   ElseIf Me.SortOrder = Desc Then
      'Greater than first item
      If Item >= mCollection.Item(1) Then
         If Key <> "" Then
            mCollection.Add Item, Key, 1
          Else
            mCollection.Add Item, , 1
          End If
      Else
        For i = CollectionCount To 1 Step -1
        'could add a binary search here can do that later
          If Item <= mCollection.Item(i) Then
             If Key <> "" Then
               mCollection.Add Item, Key, , i
             Else
               mCollection.Add Item, , , i
             End If
             Exit For
           End If
         Next i
      End If
   End If
End Function

Public Sub AddByCollection(TheCollection As Collection, Optional TheSortOrder As SortOrder = Asc)
  'Allows you to create a sorted collection from a standard collection
  If TheCollection.count > 0 Then
     mSortOrder = TheSortOrder
     If Not TypeOf TheCollection.Item(1) Is Object  Then
       Set mCollection = TheCollection
       Me.Sort TheSortOrder
     End If
  End If
End Sub

Public Function ToString() As String
  Dim i As Long
  For i = 1 To mCollection.count
    If i = 1 Then
       ToString = mCollection.Item(i)
    Else
      ToString = ToString & vbCrLf & mCollection.Item(i)
    End If
  Next i
End Function
Public Function Item(index As Variant) As Variant
  Item = mCollection.Item(index)
End Function
Public Sub Delete(index As Variant)
   mCollection.Remove index
End Sub
Public Sub Sort(Optional SortOrder As SortOrder = Asc)
    Dim Sort1 As Long
    Dim Sort2 As Long
    Dim TempItem1 As Variant
    Dim TempItem2 As Variant
    Dim CollectionCount As Long
    Dim Swap As Boolean
    CollectionCount = mCollection.count
    On Error GoTo ErrFailed
    For Sort1 = 1 To CollectionCount - 1
        For Sort2 = Sort1 + 1 To CollectionCount
        If SortOrder = Asc Then
                If mCollection.Item(Sort1) > mCollection.Item(Sort2) Then
                    Swap = True
                Else
                    Swap = False
                End If
            Else
                If mCollection.Item(Sort1) < mCollection(Sort2) Then
                    Swap = True
                Else
                    Swap = False
                End If
            End If
            If Swap Then
                'Store the items
                TempItem1 = mCollection.Item(Sort1)
                TempItem2 = mCollection.Item(Sort2)
                'Swap the items over
                mCollection.Add TempItem1, , Sort2
                mCollection.Add TempItem2, , Sort1
                'Delete the original items
                mCollection.Remove Sort1 + 1
                mCollection.Remove Sort2 + 1
            End If
        Next
    Next
    Exit Sub

ErrFailed:
    Debug.Print "Error with CollectionSort: " & Err.Description
    On Error GoTo 0
End Sub

Private Sub Class_Initialize()
  mSortOrder = Asc
End Sub

Public Property Get SortOrder() As SortOrder
  SortOrder = mSortOrder
End Property

Public Property Let SortOrder(ByVal TheSortOrder As SortOrder)
  If mSortOrder <> TheSortOrder Then
    Me.Sort TheSortOrder
  End If
  mSortOrder = TheSortOrder
End Property

 

[PHV]

Anyway, with the disconnected recordset way you may sort by any columns combination ...

 

[1DMF]

Thanks Majp.

Very true PHV!

"In complete darkness we are all the same, it is only our knowledge and wisdom that separates us, don't let your eyes deceive you."

"If a shortcut was meant to be easy, it wouldn't be a shortcut, it would be the way!"
Free Electronic Dance Music

 

[strongm]

>it crashed on a user as they didn't have .NET4

It is worth noting that you can put all the Frameworks on your development machine, and then choose the appropriate version of mscorlib to use (e.g. on my XP machine I have mscorlib for both 2.0.xxxx and 4.0.xxxx)

And of course you could always have late bound (ok, not against mscorlib, but against System) ...

 

[1DMF]

And of course you could always have late bound (ok, not against mscorlib, but against System) ...

The late binding syntax does not use mscorlib.dll, it uses system.dll and that does use the framework.

Ok confused, which is better mscorlib or late bindings with System...

I assume late bindings gives greater compatibility, but is more of an overhead?



"In complete darkness we are all the same, it is only our knowledge and wisdom that separates us, don't let your eyes deceive you."

"If a shortcut was meant to be easy, it wouldn't be a shortcut, it would be the way!"
Free Electronic Dance Music

 

[strongm]

>Ok confused, which is better mscorlib or late bindings with System...

I kinda touched on this back in my post of 11 Dec 13 7:39

Since we are playing with core namespaces, the overhead - even with late binding - is pretty low. About 6Mb I believe.

 

[1DMF]

Late bindings would appear to be a better choice then as it handles version discrepancies.

Thanks Mike, appreciated.


"In complete darkness we are all the same, it is only our knowledge and wisdom that separates us, don't let your eyes deceive you."

"If a shortcut was meant to be easy, it wouldn't be a shortcut, it would be the way!"
Free Electronic Dance Music