Efficient way to group objects in an Array - arrays

Question

I have an Array of user defined Objects. Lets say the classy, dogs.
Now I need a way to only look at all brown dogs with spots (both attributes of the Object).
I could create a new array "brown dogs" go through the original array take each dog that has brown fur and pack him in the new array. Then do another array "brown, spotted dogs" and so on you get the idea...
Works but isnt really great.
But I actually need to look at all dogs with each possible color, so all brown dogs in a group, all white dogs etc. And then create further sub groups based on further attributes.
It would be easy in an excel sheet, just filter for brown, and the other attribute, then ran the macro you want, then (by hand) filter to another color, ran code again...
I have a construct in mind that could do that in theory (take value of first attribute, create "already done colors" array, put it in their, go through whole original array, find all with the same color and then do this over and over again for all subsequent attributes) But this would be just very complexe, and hard to maintain. Isnt their an easier and quicker option to only a specific subset of values of the array (brown dogs) and repeat it for all permutations of that attribute?
Maybe this picture helps to illustrate the idea:
The basic challange is: find if the the combination of b-z (in column 2 and 3) exists for each group of column 1.
A human sees quiet quickly that for group "1" (blue) in column 1 there are 2 cases of b-z (Rows 5 and 7) but none for group "2" (green).
A programm would need to find all instances where column one is of the first value ("2") and then find all other rows with this value (rows 2,5 and 6) then for this list check column 2 and 3.
Go to the next row and check if attribute 1 was already used (it wasnt, its "1" in line two and was "2" in line one) and then compare again.
This may be doable for the given example but gets burdensome when you have several stages of grouping. So first group for Attribute one, then for ( a hyphotetical) attribute 4 and attribute 5 and then for this sub group check columns 2 an d 3 values.
Iam now looking for a way to do this "grouping" in a more managable way, is there any option for this?
Code example for what I think is a not so great version for grouping/filtering this:
dim ArrayofObjectInstances() as SpecificObject
dim ArrAlreadyUsedIds() as integer
dim ArrayOfObjectsWithSameID() as SpecificObject
For each element in ArrayofObjectInstances
If not IsinArray(elemnt.ID, ArrAlreadyUsedIds) then
For i = 1 to LenghtOfArray
if ArrayofObjectInstances(i).ID Like element.ID then
'In here I would start the for each and the for loop again for a second Attribute I want to group by, and then again for a third, each time needing more arrays
'fill the "ArrayOfObjectsWithSameID" with the current element (and the first one), then lopp through this array and check 2 Attributes if they are spevific values,
'just to then be able to say, yes the grouping for this ID has at least one instance where the reuirment is meet
end if
next
end if
next element

Answer 1

One way to go:
Test class clsTest:
Option Explicit
Public Id As Long
Public Color As String
Public Weight As String
Public Attitude As String
'added this for Debug output
Public Property Get AsString()
AsString = Join(Array(Me.Id, Me.Color, Me.Weight, Me.Attitude), "~")
End Property
Test code:
Option Explicit
Sub Tester()
Dim i As Long, obj As clsTest, col As New Collection
'create a collection of test objects with randomized property values
For i = 1 To 10
Set obj = New clsTest
obj.Id = i
obj.Color = Array("Blue", "Brown", "Yellow") _
(Application.RandBetween(0, 2))
obj.Weight = Array("Heavy", "Light")(Application.RandBetween(0, 1))
obj.Attitude = Array("Good", "Bad")(Application.RandBetween(0, 1))
col.Add obj
Next i
DumpNestedDict Classify(col, Array("Color"))
DumpNestedDict Classify(col, Array("Color", "Weight"))
DumpNestedDict Classify(col, Array("Weight", "Color", "Attitude"))
End Sub
'Classify a collection of objects according to an array of property names
'Returns a scripting dictionary (nested if >1 property) with objects
' contained in one or more collections
Function Classify(col, arrProps)
Dim dict As Object, pv, i As Long, curr As Object, obj As Object
Set dict = CreateObject("scripting.dictionary")
For Each obj In col
Set curr = dict 'start at the top level...
For i = LBound(arrProps) To UBound(arrProps)
pv = CallByName(obj, arrProps(i), VbGet) 'get the property value
If Not curr.exists(pv) Then
If i < UBound(arrProps) Then 'at the last property?
'not at last property, so create a nested dictionary
curr.Add pv, CreateObject("scripting.dictionary")
Else
'end of the road is a collection of objects
curr.Add pv, New Collection 'end of the road is a collection of objects
End If
End If
If i < UBound(arrProps) Then Set curr = curr(pv) 'one level down in the nesting
'last property, so add the object itself
If i = UBound(arrProps) Then
curr(pv).Add obj
End If
Next i
Next obj
Set Classify = dict
End Function
'create a text output from a nested dictionary containing collections of objects
' object must have an "AsString" property
Sub DumpNestedDict(d As Object, Optional level As Long = 0)
Dim k, v, s, obj
s = String(level * 3, " ")
For Each k In d.Keys
Debug.Print s & "Key:" & k
If TypeName(d(k)) = "Dictionary" Then
DumpNestedDict d(k), level + 1
ElseIf TypeName(d(k)) = "Collection" Then
For Each obj In d(k)
Debug.Print String((level + 1) * 3, " ") & obj.AsString
Next obj
End If
Next k
If level = 0 Then Debug.Print "---------------------------", vbLf
End Sub
Example output:
Key:Yellow
1~Yellow~Light~Good
3~Yellow~Light~Bad
4~Yellow~Heavy~Good
6~Yellow~Light~Bad
10~Yellow~Heavy~Good
Key:Brown
2~Brown~Light~Bad
7~Brown~Heavy~Bad
8~Brown~Heavy~Bad
Key:Blue
5~Blue~Heavy~Bad
9~Blue~Light~Good
---------------------------
Key:Yellow
Key:Light
1~Yellow~Light~Good
3~Yellow~Light~Bad
6~Yellow~Light~Bad
Key:Heavy
4~Yellow~Heavy~Good
10~Yellow~Heavy~Good
Key:Brown
Key:Light
2~Brown~Light~Bad
Key:Heavy
7~Brown~Heavy~Bad
8~Brown~Heavy~Bad
Key:Blue
Key:Heavy
5~Blue~Heavy~Bad
Key:Light
9~Blue~Light~Good
---------------------------
Key:Light
Key:Yellow
Key:Good
1~Yellow~Light~Good
Key:Bad
3~Yellow~Light~Bad
6~Yellow~Light~Bad
Key:Brown
Key:Bad
2~Brown~Light~Bad
Key:Blue
Key:Good
9~Blue~Light~Good
Key:Heavy
Key:Yellow
Key:Good
4~Yellow~Heavy~Good
10~Yellow~Heavy~Good
Key:Blue
Key:Bad
5~Blue~Heavy~Bad
Key:Brown
Key:Bad
7~Brown~Heavy~Bad
8~Brown~Heavy~Bad
---------------------------

Answer 2

Please, test the next code. I tried commenting it in a way to be understandable for somebody not familiar with dictionaries handling:
Sub testDictionariyWay()
'it needs a reference to 'Microsoft Scripting Runtime'
'The code may use late binding, but not being experienced in dictionary using, adding this reference
'you will have access to intellisense suggestions. I will also place a piece of code able to put it automatically...
Dim sh As Worksheet, arr, arrOb, dict As New Scripting.Dictionary
Dim i As Long, j As Long, boolExisting As Boolean
Set sh = ActiveSheet
arr = sh.Range("A2:C7").value 'put the range to be processed in an array (only to make the code faster and more compact)
For i = 1 To UBound(arr)
If Not dict.Exists(arr(i, 2)) Then 'if the attribute does not exist like a dictionary key:
dict.Add arr(i, 2), Array(arr(i, 1)) 'a key is created and an array of one element is placed like its value
Else
ReDim arrOb(UBound(dict(arr(i, 2))) + 1) 'redim an array able to keep all precedent array elements, plus one to be added
For j = 0 To UBound(arrOb) - 1 'iterate between the existing array elements:
If dict(arr(i, 2))(j) <> arr(i, 1) Then 'check if the object is not already in the array:
arrOb(j) = dict(arr(i, 2))(j) 'if not, it will be placed in the new array
Else
boolExisting = True: Exit For 'if the object already exists, the loop is exited and a boolean variable becomes True
End If
Next j
If Not boolExisting Then 'if not the object already exist:
arrOb(j) = arr(i, 1) 'place the new object in the last array element
dict(arr(i, 2)) = arrOb 'add the array as dictionary key value
End If
boolExisting = False 'reinitialize he boolean variable
End If
'do the same for the third column:
If Not dict.Exists(arr(i, 3)) Then
dict.Add arr(i, 3), Array(arr(i, 1))
Else
ReDim arrOb(UBound(dict(arr(i, 3))) + 1)
For j = 0 To UBound(arrOb) - 1
If dict(arr(i, 3))(j) <> arr(i, 1) Then
arrOb(j) = dict(arr(i, 3))(j)
Else
boolExisting = True: Exit For
End If
Next j
If Not boolExisting Then
arrOb(j) = arr(i, 1)
dict(arr(i, 3)) = arrOb
End If
boolExisting = False
End If
Next i
'testing the dictionary content. Now, being a strings array, Debug.Print can be used.
'Otherwise, an object will be returned and it should be Set and use one of its attributes to check the code:
Dim El As Variant
For Each El In dict("a")
Debug.Print "a: " & El
Next El
For Each El In dict("x")
Debug.Print "x: " & El
Next El
End Sub
The next piece of code will automatically add the necessary reference. Please, first run the following code, save the workbook (to keep the reference) and then run the above one:
Sub addScrRunTimeRef()
'Add a reference to 'Microsoft Scripting Runtime':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
End Sub
Edited to add a variant involving a class and its instances, to be more elocvent (at least, this is what I hope):
Create a class module, named 'clsFoo' and paste the next code:
Option Explicit
Private pmyName As String
Private pmyColor As String
Private pmyTag As String 'to identify the class Object instance (string) name...
Public Property Get myName() As String
myName = pmyName
End Property
Public Property Let myName(value As String)
pmyName = value
End Property
Public Property Get myColor() As String
myColor = pmyColor
End Property
Public Property Let myColor(value As String)
pmyColor = value
End Property
Public Property Get myTag() As String
myTag = pmyTag
End Property
Public Property Let myTag(value As String)
pmyTag = value
End Property
Try the next code showing how to create dictionaries for both class properties:
Sub testClassInstancesInDict()
Dim arrFoo(4), Foo1 As New clsFoo, Foo2 As New clsFoo, Foo3 As New clsFoo, Foo4 As New clsFoo, Foo5 As New clsFoo
Dim El As Variant, dictName As New Scripting.Dictionary, dictColor As New Scripting.Dictionary, arrClss() As clsFoo, i As Long
Foo1.myName = "Name1": Foo1.myColor = "red": Foo1.myTag = "Foo1": Set arrFoo(0) = Foo1
Foo2.myName = "Name2": Foo2.myColor = "black": Foo2.myTag = "Foo2": Set arrFoo(1) = Foo2
Foo3.myName = "Name1": Foo3.myColor = "green": Foo3.myTag = "Foo3": Set arrFoo(2) = Foo3
Foo4.myName = "Name4": Foo4.myColor = "black": Foo4.myTag = "Foo4": Set arrFoo(3) = Foo4
Foo5.myName = "Name1": Foo5.myColor = "white": Foo5.myTag = "Foo5": Set arrFoo(4) = Foo5
For Each El In arrFoo
'process dictName dictionary:
If Not dictName.Exists(El.myName) Then
dictName.Add El.myName, Array(El)
Else
ReDim arrClss(UBound(dictName(El.myName)) + 1)
For i = 0 To UBound(dictName(El.myName))
Set arrClss(i) = dictName(El.myName)(i)
Next i
Set arrClss(i) = El: dictName(El.myName) = arrClss
End If
'process dictColor dictionary:
If Not dictColor.Exists(El.myColor) Then
dictColor.Add El.myColor, Array(El)
Else
ReDim arrClss(UBound(dictColor(El.myColor)) + 1)
For i = 0 To UBound(dictColor(El.myColor))
Set arrClss(i) = dictColor(El.myColor)(i)
Next i
Set arrClss(i) = El: dictColor(El.myColor) = arrClss
End If
Next
'test the resulted dictionaries:
Debug.Print "DictName Name1 key has " & UBound(dictName("Name1")) & " clsFoo objects"
Debug.Print "DictColor black key has " & UBound(dictColor("black")) & " clsFoo objects"
Dim j As Long
'all dictName keys/items. myTag returns the object string name:
Debug.Print "dictName _________________________"
For j = 0 To dictName.count - 1
For i = 0 To UBound(dictName.items(j))
Debug.Print "KeyName: " & dictName.Keys(j) & vbTab & dictName.items(j)(i).myName & _
vbTab & dictName.items(j)(i).myColor & vbTab & dictName.items(j)(i).myTag
Next i
Next
'all dictColor keys/items:
Debug.Print: Debug.Print "dictColor ________________________"
For j = 0 To dictColor.count - 1
For i = 0 To UBound(dictColor.items(j))
Debug.Print "KeyColor: " & dictColor.Keys(j) & vbTab & dictColor.items(j)(i).myName & _
vbTab & dictColor.items(j)(i).myColor & vbTab & dictColor.items(j)(i).myTag
Next i
Next
End Sub