This is my first foray into VBA.
How can I put an array into a collection? I am making a collection with keys which contains reference data. It gets made once, and then used throughout my program. Everything I've found is either reading data in from a sheet in Excel, taking user input, or just putting in a couple of previously defined arrays; I want to do the initialisation of the arrays in the add call to the collection, as they aren't going to be used anywhere else.
I want to do something along the lines of
Dim c As Collection
Set c = New Collection
c.Add((1,"B"), "B")
c.Add((1.014,"FeC"), "Fe")
... 'about 100 lines
I can then retrieve the data by key, rather then having a hard to maintain If/ElseIf.
In Python, I would do
c = {"B": (1,"B"), "Fe": (1.014,"FeC"), ...}
A strange day. Two questions where I can use the same answer (see Convert 2 collections to a dictionary).
The basic advice I would give is to use a Scripting.Dictionary if only for the reason that you can get arrays back out using the Keys and Items Methods.
Here is the answer reproduced from the reference above
Inserting two collections (or any combination of an array or collection) into a dictionary is essentially boilerplate code. The best way to deal with boilerplate code is to put it in the object so that scripting dictionary would end up with a Method called 'AddPairs'.
In VBA you can't do this directly. Instead, you have to use a Wrapper, which is a term used for putting an object inside another object and using pass through methods to use the inner object. The class below 'wDictionary', shows how to Wrap the Scripting.Dictionary object to add the functionality you desire, plus an additional method which does what you want in reverse.
The AddPairs Method allows collections or Arrays to be used for the Keys and Items so, assuming you are now using wCollection you can write
pairs.AddPairs rembs, cols
The wDictionary also has a 'Pairs' method. The pairs method returns an array in the same way as the 'Items' and 'Keys' methods, but, each Item is an array of three Items, the Index, Key and Item. If you've been programming for a while, you'll understand the utility of the Pairs method.
Save the code below as a .cls file and then import it into your project. Replace references to Scripting.Dictionary with wDictionary (or New wDictionary if you are using CreateObject)
The code below is provided as an example. I haven't run any tests but I have done Rubberduck code inspections to ensure that there are no obvious errors.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "wDictionary"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Private Type State
Host As Scripting.Dictionary
End Type
Private s As State
Private Sub Class_Initialize()
Set s.Host = New Scripting.Dictionary
End Sub
Public Sub Add(ByRef Key As Variant, ByRef Item As Variant)
s.Host.Add Key, Item
End Sub
' An Enhancement - The Keys and Items variants must support For each and (Index) or defaultmemeber .Item(Index)
Public Sub AddPairs(ByVal Keys As Variant, ByRef Items As Variant)
Dim myItemsIndex As Long
Dim myLastItemsIndex As Long
If TypeName(Items) = "Collection" Then
myItemsIndex = 1
myLastItemsIndex = Items.Count
Else
myItemsIndex = LBound(Items)
myLastItemsIndex = UBound(Items)
End If
Dim myKey As Variant
For Each myKey In Keys
If myItemsIndex > myLastItemsIndex Then
Exit For
Else
s.Host.Add myKey, Items(myItemsIndex)
myItemsIndex = myItemsIndex + 1
End If
Next
End Sub
Public Property Get CompareMode() As VbCompareMethod
CompareMode = s.Host.CompareMode
End Property
Public Property Let CompareMode(ByVal RHS As VbCompareMethod)
s.Host.CompareMode = RHS
End Property
Public Property Get Count() As Long
Count = s.Host.Count
End Property
Public Function Exists(ByRef Key As Variant) As Boolean
Exists = s.Host.Exists(Key)
End Function
'#DefaultMember
Public Property Get Item(ByRef Key As Variant) As Variant
Attribute Item.VB_UserMemId = 0
If VBA.IsObject(s.Host(Key)) Then
Set Item = s.Host(Key)
Else
Item = s.Host(Key)
End If
End Property
Public Property Let Item(ByRef Key As Variant, ByVal RHS As Variant)
s.Host(Key) = RHS
End Property
Public Property Set Item(ByRef Key As Variant, ByVal RHS As Variant)
Set s.Host(Key) = RHS
End Property
Public Function Items() As Variant
Items = s.Host.Items
End Function
Public Function Keys() As Variant
Keys = s.Host.Keys
End Function
' An enhancement For Each myItem in myDictionary.Pairs return an array containing an index, key and value (items 0,1,2 respectively)
Public Function Pairs() As Variant
Dim myPairs As Variant
ReDim myPairs(0 To s.Host.Count - 1)
Dim myIndex As Long
myIndex = 0
Dim myKey As Variant
For Each myKey In s.Host
myPairs(myIndex) = Array(myIndex, myKey, s.Host(myKey))
myIndex = myIndex + 1
Next
Pairs = myPairs
End Function
Public Property Let Key(ByRef Key As Variant, ByVal NewKey As Variant)
s.Host.Key(Key) = NewKey
End Property
Public Sub Remove(ByRef Key As Variant)
s.Host.Remove Key
End Sub
Public Sub RemoveAll()
s.Host.RemoveAll
End Sub
Update
Of course, the above is quite tedious to write, even though you any have to do the base wrapping once. This is where twinBasic (the up and coming replacement for VB/VBA) has a definite edge. In twin basic the whole code presented above can be condensed to
Class wDictionary
Implements Scripting.dictionary Via Host = New scripting.dictionary
' An enhancement For Each myItem in myDictionary.Pairs return an array containing an index, key and value (items 0,1,2 respectively)
Public Function Pairs() As Variant
Dim myPairs As Variant
ReDim myPairs(0 To s.Host.Count - 1)
Dim myIndex As Long = 0
Dim myKey As Variant
For Each myKey In Host
myPairs(myIndex) = Array(myIndex, myKey, s.Host(myKey))
myIndex += 1
Next
Return myPairs
End Function
' An Enhancement - The Keys and Items variants must support For each and (Index) or defaultmemeber .Item(Index)
Public Sub AddPairs(ByVal Keys As Variant, ByRef Items As Variant)
Dim myItemsIndex As Long
Dim myLastItemsIndex As Long
If TypeName(Items) = "Collection" Then
myItemsIndex = 1
myLastItemsIndex = Items.Count
Else
myItemsIndex = LBound(Items)
myLastItemsIndex = UBound(Items)
End If
Dim myKey As Variant
For Each myKey In Keys
If myItemsIndex > myLastItemsIndex Then
Exit For
Else
Host.Add myKey, Items(myItemsIndex)
myItemsIndex += 1
End If
Next
End Sub
End Class
What's more, twinBasic makes it absolutely trivial to convert wCollection to an activeX.dll so that you can just add a reference to wCOllection just as you do for Scripting.DIctionary etc.
Related
Ok to start off, I read through this.
It is close although it doesn't answer my specific question. This talks about taking smaller collections and adding items to a larger main collection. Then destroying the smaller collection.
I have two definitions under Class Modules.
TimeDet
Option Explicit
Public recDate As String
Public recQty As String
Public recDieNo As String
Public recCatID As String
Public recCatName As String
Public recGroupID As String
Public recGroupName As String
TimeRec
Option Explicit
Private objTimeRec As Collection
Private Sub Class_Initialize()
Set objTimeRec = New Collection
End Sub
Private Sub Class_Terminate()
Set objTimeRec = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = objTimeRec.[_NewEnum]
End Property
Public Sub Add(obj As TimeDet)
objTimeRec.Add obj
End Sub
Public Sub Remove(Index As Variant)
objTimeRec.Remove Index
End Sub
Public Property Get Item(Index As Variant) As TimeDet
Set Item = objTimeRec.Item(Index)
End Property
Property Get Count() As Long
Count = objTimeRec.Count
End Property
Public Sub Clear()
Set objTimeRec = New Collection
End Sub
Public Sub FillFromArray(Arr As Variant)
Dim i As Long, obj As TimeDet
For i = 1 To UBound(Arr)
Set obj = New TimeDet
obj.recDate = Arr(i, 1)
obj.recQty = Arr(i, 2)
obj.recDieNo = Arr(i, 3)
obj.recCatID = Arr(i, 4)
obj.recCatName = Arr(i, 5)
obj.recGroupID = Arr(i, 6)
obj.recGroupName = Arr(i, 7)
Me.Add obj
Next
End Sub
Then in the code I am using it this way:
Sub Test()
Dim RecSet1 As TimeRec, Record As TimeDet
Dim fSet1 As TimeRec, fRecord As TimeDet
Dim repArray() As Variant
Dim startDT As Date, endDT As Date, dieNo As String
repArray() = Sheet4.Range("A2:G" & Sheet4.Range("A2").End(xlDown).Row)
Set RecSet1 = New TimeRec
Set fSet1 = New TimeRec
RecSet1.FillFromArray (repArray())
startDT = "1-1-2015"
endDT = "1-1-2016"
dieNo = "16185"
For Each Record In RecSet1
If Record.recDate <= endDT And Record.recDate >= startDT And Record.recDieNo = dieNo Then
fSet1.Add (Record)
End If
Next
End Sub
I am getting an error when I try to add the Record object to the fSet1 object.
"Object doesn't support this method or property"
The Record object is Type TimeDet which as you can see up in the class module my Add method is expecting type TimeDet.
Either I am missing something very simple and have blinders on, or this is a bigger issue.
The array has 200,000 records roughly. I am attempting to create a smaller subset of filtered data. Maybe I am approaching this from the wrong way.
Your error is not at Add but at For Each
Most likely you copied your TimeRec Class. In VBA, you can't create enumerable classes inside the VBE (VBA IDE). There's a different way of creating Enumerable classes.
Open a notepad, copy all your class code and then add this attribute to NewEnum property Attribute NewEnum.VB_UserMemId = -4
Then import the class.
This is always hidden in VBA code, but can be seen in text editors.
Also add this attribute to Item property, it will make it default and allows syntax like ClassName(1)
Attribute Item.VB_UserMemId = 0
So , your code in text editor/ notepad should be:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Class1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private objTimeRec As Collection
Private Sub Class_Initialize()
Set objTimeRec = New Collection
End Sub
Private Sub Class_Terminate()
Set objTimeRec = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Set NewEnum = objTimeRec.[_NewEnum]
End Property
Public Sub Add(obj As Class2)
objTimeRec.Add obj
End Sub
Public Sub Remove(Index As Variant)
objTimeRec.Remove Index
End Sub
Public Property Get Item(Index As Variant) As Class2
Attribute Item.VB_UserMemId = 0
Set Item = objTimeRec.Item(Index)
End Property
Property Get Count() As Long
Count = objTimeRec.Count
End Property
Public Sub Clear()
Set objTimeRec = New Collection
End Sub
The answer to this particular problem was to remove the parenthesis form my Add method. That being said, the attribute info being hidden was really good info and would have probably contributed to the problem after I figured out that removing the parenthesis fixed it.
I'm trying make to a 3 Dimension Dictionary to store the data in the form of tools(material)(part)(attribute), and I have managed to create the Dictionary like this:
Dim Tools As New Dictionary(Of String, Dictionary(Of String, Dictionary(Of String, Decimal)))
And what I basically want to do is have some subs that manage that for me instead of dealing with that mess, and I want it to be like this like this:
Add_Attribute("Iron", "Pickaxe Head", "Durability", 204)
Get_Attribute("Stone", "Pickaxe Head", "Mining Speed")
Any answers would be greatly be appreciated.
My comment was not worded properly.
Create a class with add/get attributes function that accepts 3 parameters.
Concatenate the parameters and use it as dictionary key.
Option Explicit
Dim oDict As Dictionary
Public Function Add_Attribute(psParam1 As String, psParam2 As String, psParam3 As String, psValue As String)
Dim sKey As String
sKey = BuildKey(psParam1, psParam2, psParam3)
If oDict.Exists(sKey) Then
oDict.Item(sKey) = psValue
Else
oDict.Add sKey, psValue
End If
End Function
Public Function Get_Attribute(psParam1 As String, psParam2 As String, psParam3 As String) As String
Dim sKey As String
sKey = BuildKey(psParam1, psParam2, psParam3)
If oDict.Exists(sKey) Then
Get_Attribute = oDict.Item(sKey)
Else
Get_Attribute = ""
End If
End Function
Private Sub Class_Initialize()
Set oDict = New Dictionary
End Sub
Private Function BuildKey(psParam1 As String, psParam2 As String, psParam3 As String) As String
BuildKey = Join(Array(psParam1, psParam2, psParam3), "#")
End Function
Private Sub Class_Terminate()
Set oDict = Nothing
End Sub
Jules' answer of a custom class and concatenation of the three strings as a key will work very nicely for you and is a neat solution to your problem.
I'm posting another answer here for anyone who wants more of a dot notation style of solution. So one of the lines in your example could look something like:
mTools("Pickaxe Head").Attr("Durability").Material("Iron") = 204
I'm guessing you're deriving the values from a comboxbox or something similar, so working with strings might serve you fine. However, if you wished, you could go one stage further and create objects for the Attributes and Material parameters to achieve true dot notation (I didn't do the Parts parameter but you could do that one too):
mTools("Pickaxe Head").Durability.OnIron = 204
From a development point of view, the time consuming part would be to create all the parameter objects and keys, but if you are intending to manipulate the data anything more than trivially, it could make your life easier further down the track.
For your own project, are you certain that the data is genuinely 3 dimensional? Perhaps it's just the variable names that you've picked, but it seems as though you have one main object, ie the part (Pickaxe Head) which has some attributes (Durability and Mining Speed) which themselves have values based on the material they're operating on (Stone and Iron). Structurally, could it look like this?:
In terms of the code for this solution, create three classes. I've called them clsKeys, clsMaterials and clsPart.
For your clsKeys, the code is simply your field names:
Public Durability As String
Public MiningSpeed As String
Public Iron As String
Public Stone As String
For clsPart, the code contains the object names and a means of accessing them by string:
Public Name As String
Public Durability As New clsMaterials
Public MiningSpeed As New clsMaterials
Private mProperties As New Collection
Public Property Get Attr(field As String) As clsMaterials
Set Attr = mProperties(field)
End Property
Private Sub Class_Initialize()
With Keys
mProperties.Add Durability, .Durability
mProperties.Add MiningSpeed, .MiningSpeed
End With
End Sub
clsMaterials is similar:
Public OnStone As Integer
Public OnIron As Integer
Private mProperties As New Collection
Public Property Let Material(field As String, value As Variant)
mProperties.Remove field
mProperties.Add value, field
End Property
Public Property Get Material(field As String) As Variant
Material = mProperties(field)
End Property
Private Sub Class_Initialize()
With Keys
mProperties.Add OnStone, .Stone
mProperties.Add OnIron, .Iron
End With
End Sub
These classes can take as many objects as you like. You'll note I've instantiated the objects in the declaration which isn't best form but I've done it in the interest of space.
Finally, in a Module you need 3 routines: one to create the field keys, one to populate the data and one to retrieve it.
For the keys:
Option Explicit
Public Keys As clsKeys
Private mTools As Collection
Sub CreateKeys()
Set Keys = New clsKeys
With Keys
.Durability = "Durability"
.MiningSpeed = "Mining Speed"
.Iron = "Iron"
.Stone = "Stone"
End With
End Sub
For data population:
Sub PopulateData()
Dim oPart As clsPart
Set mTools = New Collection
Set oPart = New clsPart
With oPart
.Name = "Pickaxe Head"
'You could use dot notation
.Durability.OnIron = 204
.Durability.OnStone = 100
'Or plain strings
.Attr("Mining Speed").Material("Stone") = 50
.Attr("Mining Speed").Material("Iron") = 200
mTools.Add oPart, .Name
End With
End Sub
and for data retrieval:
Sub RetrieveValue()
Dim oPart As clsPart
Dim v As Variant
Set oPart = mTools("Pickaxe Head")
With oPart
'Using dot notation
v = oPart.Durability.OnIron
Debug.Print v
'Using plain strings
v = oPart.Attr("Durability").Material("Stone")
Debug.Print v
End With
'Or even without assigning the oPart variable
v = mTools("Pickaxe Head").Attr("Mining Speed").Material("Iron")
Debug.Print v
End Sub
I need good map class implementation in VBA.
This is my implementation for integer key
Box class:
Private key As Long 'Key, only positive digit
Private value As String 'Value, only
'Value getter
Public Function GetValue() As String
GetValue = value
End Function
'Value setter
Public Function setValue(pValue As String)
value = pValue
End Function
'Ket setter
Public Function setKey(pKey As Long)
Key = pKey
End Function
'Key getter
Public Function GetKey() As Long
GetKey = Key
End Function
Private Sub Class_Initialize()
End Sub
Private Sub Class_Terminate()
End Sub
Map class:
Private boxCollection As Collection
'Init
Private Sub Class_Initialize()
Set boxCollection = New Collection
End Sub
'Destroy
Private Sub Class_Terminate()
Set boxCollection = Nothing
End Sub
'Add element(Box) to collection
Public Function Add(Key As Long, value As String)
If (Key > 0) And (containsKey(Key) Is Nothing) Then
Dim aBox As New Box
With aBox
.setKey (Key)
.setValue (value)
End With
boxCollection.Add aBox
Else
MsgBox ("В словаре уже содержится элемент с ключем " + CStr(Key))
End If
End Function
'Get key by value or -1
Public Function GetKey(value As String) As Long
Dim gkBox As Box
Set gkBox = containsValue(value)
If gkBox Is Nothing Then
GetKey = -1
Else
GetKey = gkBox.GetKey
End If
End Function
'Get value by key or message
Public Function GetValue(Key As Long) As String
Dim gvBox As Box
Set gvBox = containsKey(Key)
If gvBox Is Nothing Then
MsgBox ("Key " + CStr(Key) + " dont exist")
Else
GetValue = gvBox.GetValue
End If
End Function
'Remove element from collection
Public Function Remove(Key As Long)
Dim index As Long
index = getIndex(Key)
If index > 0 Then
boxCollection.Remove (index)
End If
End Function
'Get count of element in collection
Public Function GetCount() As Long
GetCount = boxCollection.Count
End Function
'Get object by key
Private Function containsKey(Key As Long) As Box
If boxCollection.Count > 0 Then
Dim i As Long
For i = 1 To boxCollection.Count
Dim fBox As Box
Set fBox = boxCollection.Item(i)
If fBox.GetKey = Key Then Set containsKey = fBox
Next i
End If
End Function
'Get object by value
Private Function containsValue(value As String) As Box
If boxCollection.Count > 0 Then
Dim i As Long
For i = 1 To boxCollection.Count
Dim fBox As Box
Set fBox = boxCollection.Item(i)
If fBox.GetValue = value Then Set containsValue = fBox
Next i
End If
End Function
'Get element index by key
Private Function getIndex(Key As Long) As Long
getIndex = -1
If boxCollection.Count > 0 Then
For i = 1 To boxCollection.Count
Dim fBox As Box
Set fBox = boxCollection.Item(i)
If fBox.GetKey = Key Then getIndex = i
Next i
End If
End Function
All ok if i insert 1000 pairs key-value. But if 50000, a program freezes.
How i can solve this problem? Or maybe there more better solution?
Main problem with your implementation is that the operation containsKey is quite expensive (O(n) complex) and it is called at every insert and it never breaks even when it "knows" what would be the result.
This might help a little:
...
If fBox.GetKey = Key Then
Set containsKey = fBox
Exit Function
End If
...
In order to reduce the containsKey complexity typical things to do would be
keep the keys sorted so that you can use binary search instead of linear search
keep the keys in tree or in a hashed buckets
The most straightforward thing to do would be using the Collection's built-in (hopefully optimized) ability to store/retrieve items by a key.
Store:
...
boxCollection.Add Item := aBox, Key := CStr(Key)
...
Retrieve (not tested, based on this answer):
Private Function containsKey(Key As Long) As Box
On Error GoTo err
Set containsKey = boxCollection.Item(CStr(Key))
Exit Function
err:
Set containsKey = Nothing
End Function
See also:
MSDN: How to: Add, Delete, and Retrieve Items of a Collection (Visual Basic)
Stack Overflow: Does VBA have Dictionary Structure?
Newton Excel Bach: Arrays vs Collections vs Dictionary Objects (and Dictionary help)
I have a program where I create several different collections in VBA. After the program completes, I need to delete the records in each collection. I have been able to delete the collections statically with the following code:
Sub Empty_Collections()
Dim Count As Integer
Dim i As Long
Count = Managers.Count
For i = 1 To Count
Managers.Remove (Managers.Count)
Next i
Count = FS.Count
For i = 1 To Count
FS.Remove (FS.Count)
Next i
Count = Staff.Count
For i = 1 To Count
Staff.Remove (Staff.Count)
Next i
Count = Clusters.Count
For i = 1 To Count
Clusters.Remove (Clusters.Count)
Next i
End Sub
However, as I may add additional Collections in the future, is it possible to have code similar to this:
Dim Item As Collection
Dim Count As Integer
Dim i As Long
For Each Item In Worksheets
Count = Item.Count
For i = 1 To Count
Item.Remove (Item.Count)
Next i
Next
While I hesitate to create globals like this, here is a possible solution:
In the ThisWorkbook Excel Object, add the following:
Private pCollections As Collection
Public Property Get Collections() As Collection
If pCollections Is Nothing Then: Set pCollections = New Collection
Set Collections = pCollections
End Property
Public Property Set Collections(Value As Collection)
Set pCollections = Value
End Property
Public Sub AddCollection(Name As String)
Dim Coll As New Collection
Me.Collections.Add Coll, Name
End Sub
Public Sub EmptyCollections()
Dim Coll As Collection
For Each Coll In Me.Collections
EmptyCollection Coll
Next Coll
End Sub
Private Sub EmptyCollection(ByRef Coll As Collection)
Do While Coll.Count > 0
' Remove items from the end of the collection
Coll.Remove Coll.Count
Loop
End Sub
Then add and work with collections as follows:
' Add collections
' (without helper)
Dim Managers As New Collection
ThisWorkbook.Collections.Add Managers, "Managers"
' (with helper)
ThisWorkbook.AddCollection "FS"
ThisWorkbook.AddCollection "Staff"
ThisWorkbook.AddCollection "Clusters"
' Add items to collection
' (access collection via named key for ease-of-use)
ThisWorkbook.Collections("Managers").Add "Alice"
ThisWorkbook.Collections("Managers").Add "Bob"
' (or original reference if desired
Managers.Add "Carl"
Debug.Print Managers.Count ' => 3
Debug.Print ThisWorkbook.Collections("Managers").Count ' => 3
' Add collection later
ThisWorkbook.AddCollection "FutureCollection"
' Empty all collections
ThisWorkbook.EmptyCollections
This may be a little more complex than what you are looking for, but it has the advantage of adding collections to a central location so that they can all be emptied later.
I have created a sort function to allow a collection of instances of a custom object to be sorted based on one of the objects properties. Is it possible to extend the existing collections class in VBA? I do not believe inheritance is supported in VBA, so I am not sure how to go about this in the proper way. I could just create a new module and place the function in that module, but that doesn't seem like the best way of doing it.
Thanks for the responses. I ended up creating my own class which extends the Collections class in VBA. Below is the code if anyone is interested.
'Custom collections class is based on the Collections class, this class extendes that
'functionallity so that the sort method for a collection of objects is part of
'the class.
'One note on this class is that in order to make this work in VBA, the Attribute method has to be added
'manually. To do this, create the class, then export it out of the project. Open in a text editor and
'add this line Attribute Item.VB_UserMemId = 0 under the Item() function and this line
'Attribute NewEnum.VB_UserMemId = -4 under the NewEnum() function. Save and import back into project.
'This allows the Procedure Attribute to be recognized.
Option Explicit
Private pCollection As Collection
Private Sub Class_Initialize()
Set pCollection = New Collection
End Sub
Private Sub Class_Terminate()
Set pCollection = Nothing
End Sub
Function NewEnum() As IUnknown
Set NewEnum = pCollection.[_NewEnum]
End Function
Public Function Count() As Long
Count = pCollection.Count
End Function
Public Function item(key As Variant) As clsCustomCollection
item = pCollection(key)
End Function
'Implements a selection sort algorithm, could likely be improved, but meets the current need.
Public Sub SortByProperty(sortPropertyName As String, sortAscending As Boolean)
Dim item As Object
Dim i As Long
Dim j As Long
Dim minIndex As Long
Dim minValue As Variant
Dim testValue As Variant
Dim swapValues As Boolean
Dim sKey As String
For i = 1 To pCollection.Count - 1
Set item = pCollection(i)
minValue = CallByName(item, sortPropertyName, VbGet)
minIndex = i
For j = i + 1 To pCollection.Count
Set item = pCollection(j)
testValue = CallByName(item, sortPropertyName, VbGet)
If (sortAscending) Then
swapValues = (testValue < minValue)
Else
swapValues = (testValue > minValue)
End If
If (swapValues) Then
minValue = testValue
minIndex = j
End If
Set item = Nothing
Next j
If (minIndex <> i) Then
Set item = pCollection(minIndex)
pCollection.Remove minIndex
pCollection.Add item, , i
Set item = Nothing
End If
Set item = Nothing
Next i
End Sub
Public Sub Add(value As Variant, key As Variant)
pCollection.Add value, key
End Sub
Public Sub Remove(key As Variant)
pCollection.Remove key
End Sub
Public Sub Clear()
Set m_PrivateCollection = New Collection
End Sub
One popular option is to use an ADO disconnected recordset as a sort of hyperpowered collection/dictionary object, which has built-in support for Sort. Although you are using ADO, you don't need a database.
I would create a wrapper class that exposes the collection object's properties, substituting the sort function with your own.