VBA - The most efficient method of filtering a collection / dictionary of user-defined classes by attribute

Question

My question is about filtering a collection of vba or dictionaries based on a property field. I use VBA to handle many data extracts, and for this purpose there is a series of specialized class objects. After I defined them and filled them in a collection or dictionary, I need to select a subset of these objects based on various attributes. My question is: is there a more efficient way to do this than just sorting and testing a condition?

Below is the base code illustrating the problem. I can’t even download the sample Excel file because of my policies in the workplace, but the data is really not up to date. My test file is just a bunch of randbetween functions like '= select (randbetween (1,3), "red", "green", "blue")

'Simple Class definition
Option Explicit
'very simple test class
'One field is unique, the other three are simple strings that 
'fall into    groups (I don't always know what the groups will bee)

Private m_uniqueID As String
Private m_strTest1 As String
Private m_strTest2 As String
Private m_strTest3 As String

Public Property Get uniqueID() As String: uniqueID = m_uniqueID: End Property
Public Property Let uniqueID(ByVal NewValue As String): m_uniqueID = NewValue: End Property
Public Property Get strTest1() As String: strTest1 = m_strTest1: End Property
Public Property Let strTest1(ByVal NewValue As String): m_strTest1 = NewValue: End Property
Public Property Get strTest2() As String: strTest2 = m_strTest2: End Property
Public Property Let strTest2(ByVal NewValue As String): m_strTest2 = NewValue: End Property
Public Property Get strTest3() As String: strTest3 = m_strTest3: End Property
Public Property Let strTest3(ByVal NewValue As String): m_strTest3 =   NewValue: End Property

And my basic approach to filtering:

Public Sub inefficientFilter()
    Dim oTest As cl_Test
    Dim colTest As Collection
    'assume it populated

    Dim colMatches As Collection
    Set colMatches = New Collection

    For Each oTest In colTest
        If oTest.strTest1 = "Green" Then
            colMatches.Add Item:=oTest, Key:=oTest.uniqueID
        End If
    Next oTest
End Sub

, ( 17 100 000 ). , . , , , , . , , ( , , , , , ).

, , , , , , , , . , , - - excel, adodb.recordset ( , , ). , , , , - .

!

-added 12/15

Mat Mug .... , . , . 7 , . , , . , . 10 000 ( , 300 000). , , , ( , , , ):

• 0.00578 , ( )
• 0.20099 , , SET obj = col (i)
• 0.27605 , , 2, SET.
  , col (i).strtest1 = "" , ...)
• 0.01275 . dict.keys, SET obj = dict ()
• 0.02605 dict SET, 3, dict ().strtest1 = "" , ...)
• 3.68905 Next , = 1 to dict.count, o = dict (i)
• 4.16361 , 6, SET dict.items(i).strTest1 = "" , ...
• 0.02192

, , . , VBA ( SET), . - FOR EACH obj IN Collection, NEXT obj loop. (FOR EACH key IN dict.keys, SET obj = dict (key), NEXT) , ( , , SET), , , ( ), . - .

, , , ( , , ). , , , 1 , , , 1 , , 50 , , , .

Method__1x (1x) __ 50x _____ (50x) 1 _______ 0,006 ____ 1 _________ 0,159 _______ 1__loop 2 _______ 0.201 ___ 35 _________ 0.336 _______ 2__ 3 _______ 0.276 ___ 48 ________ 19.165 _____ 120 # 2 SET 4 _______ 0,013 ____ 2 _________ 0,159 _______ 1__ dict 5 _______ 0,026 ____ 5 _________ 5.560 ______ 35 __ # 4 SET 6 _______ 3.689__369 _________ 3.851 ______ 24__ dict 7 _______ 4.164__721 _______ 211.929 ____ 1333 __ # 6 SET 8 _______ ____ 0,022 4 0,144 _________ _______ 1__Mr.

, . dict.keys, set obj = dict (key) - , . , , , . , , VBA , , /. , , , , , , .

, . , . , , , , .

Answer 1

300k, example.

EDIT: .

Dim data As Object

Sub Tester()

    Dim colF As Collection
    Dim arr, o As Class1, n As Long, t, k, o2 As Variant

    arr = Array("Red", "Green", "Blue")
    Set data = CreateObject("scripting.dictionary")

    'load up some test data
    t = Timer
    For n = 1 To 300000#
        Set o = New Class1
        o.uniqueID = "ID" & Format(n, "000000000")
        o.strTest1 = arr(Int((2 - 0 + 1) * Rnd + 0))
        o.strTest2 = arr(Int((2 - 0 + 1) * Rnd + 0))
        o.strTest3 = arr(Int((2 - 0 + 1) * Rnd + 0))
        data.Add o.uniqueID, o
    Next n
    Debug.Print "Loaded", Timer - t

    'do some filtering
    t = Timer
    Debug.Print "filtered", Filtered("strTest1", "Red").Count, Timer - t
    t = Timer
    Debug.Print "filtered", Filtered("strTest2", "Green").Count, Timer - t
    t = Timer
    Debug.Print "filtered", Filtered("strTest3", "Blue").Count, Timer - t

End Sub

'generic filtering on named property+value
Function Filtered(propName As String, propValue As String) As Collection
    Dim rv As New Collection, o As Variant
    For Each o In data.items
        If CallByName(o, propName, VbGet) = propValue Then rv.Add o.uniqueID
    Next o
    Set Filtered = rv
End Function

:

Loaded                       6.601563 
filtered       100006        0.7109375 
filtered       99936         0.828125 
filtered       100144        0.9609375 

- : .

- , , . , , , , .

Answer 2

- . .

50% , @TimWilliams, 4 , 1 .

: clTest_Collection

Public dictAll As Object
Public dicStr1 As Object
Public dicStr2 As Object
Public dicStr3 As Object

Public Sub Add(uniqueID As String, str1 As String, str2 As String, str3 As String)
    Dim obj As cl_Test
    Set obj = New cl_Test
    With obj
        .uniqueID = uniqueID
        .strTest1 = str1
        .strTest2 = str1
        .strTest3 = str1
    End With

    dictAll.Add obj.uniqueID, obj
    AddToDictionary dicStr1, obj, str1
    AddToDictionary dicStr2, obj, str2
    AddToDictionary dicStr3, obj, str3

End Sub

Private Sub AddToDictionary(ByRef dict As Object, ByRef obj As cl_Test, ByRef value As String)
    If Not dict.Exists(value) Then dict.Add value, CreateObject("Scripting.Dictionary")
    dict(value).Add obj.uniqueID, obj
End Sub

Private Sub Class_Initialize()
    Set dictAll = CreateObject("Scripting.Dictionary")
    Set dicStr1 = CreateObject("Scripting.Dictionary")
    Set dicStr2 = CreateObject("Scripting.Dictionary")
    Set dicStr3 = CreateObject("Scripting.Dictionary")
End Sub

1:

Sub Test()
    Dim t As Single, x As Long
    Dim ObjCollection As clTest_Collection
    Set ObjCollection = New clTest_Collection

    t = Timer
    For x = 1 To 300000
        ObjCollection.Add "Item" & x, getRndColor, getRndColor, getRndColor
    Next
     Debug.Print "Total Time in Seconds: "; Timer - t
End Sub

Function getRndColor() As String
    getRndColor = Choose(Int(Rnd * 3) + 1, "Red", "Green", "Blue")
End Function