Question

我的问题是根据属性字段过滤vba集合或词典。我使用VBA处理大量数据提取，并为此目的提供了一系列自定义类对象。一旦我定义了它们并将它们填充到集合或字典中，我就需要根据各种属性选择这些对象的子集。我的问题是，有没有比简单地循环和测试条件更有效的方法呢？

以下是一些用于说明问题的基本代码。由于我的工作场所政策，我甚至无法上传示例Excel文件，但数据并不真实。我的测试文件只是一堆rand之间的函数，例如＆＃39; =选择（randbetween（1,3），＆＃34; red＆＃34;，＆＃34; green＆＃34;，＆＃34; blue＆＃ 34;）

'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

我的过滤基线方法：

Public Sub inefficientFilter()
    Dim oTest As cl_Test
    Dim colTest As Collection
    'assume it's 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

这很好用，只是执行时间增长得相当快（现在100,000行的时间长达17秒）。我已经尝试了一段时间来搜索这个方法，我发现很多过滤源表的引用。但是，这对我的数据集来说不实用，因为数据在读入后经过大量处理，并且我需要过滤的一些属性未在输入中定义。而且，我需要在许多不同的属性上过滤它，其中一些我事先不知道（我的意思是我知道一个字段将包含类别，但我不知道是什么这些类别是在数据处理之前，它们可能会随着下一个数据集而改变。）

如果没有一种过滤字典或集合的方法比循环选择更有效，那么我计划创建一个为每个分类字段创建集合的大型过滤函数，这样我就可以每次我需要应用过滤器并一次性处理它时，最少避免循环。或者，也可以将哈希表中的某些内容写入单个Excel工作表，然后使用adodb.recordset查询来查找匹配项（我还没有对其进行测试，以确定哪些内容具有较少的开销）。然而，在我去那里之前，我想我会问我是否遗漏了一些明显的东西。

谢谢！

-added 12/15

Mat Mug的第一条评论提到迭代字典的键数组，并建议使用for ... next循环。所以我去修改了我的代码来测试不同迭代方法的时间。我想我应该分享结果。我测试了7种方法，以及Tim William的答案如下。我认为在没有完全详细说明代码的情况下总结一下是可以的，因为它非常简单。如果我错了，我可以轻松添加它。我在10,000件物品上运行了这个（因为如果我去了300k，两种方法导致我的电脑自杀）。所以这里是结果，完成循环的持续时间以秒为单位（每个循环遍历集合或字典，然后针对给定条件测试每个项目，如果匹配则将该项添加到结果集合）：

0.00578对于每个循环，循环遍历集合（对于col中的每个o）
0.20099对于Next Loop，使用计数器作为集合的索引，和然后通过SET obj = col（i）
0.27605对于Next Loop，与2相同，但跳过SET 所以测试条件是col（i）.strtest1 =＆＃34; Green＆＃34;然后......）
0.01275字典现在。对于dict.keys中的每个键，SET obj = dict（key）
0.02605对于dict中的每个键不包括SET，所以3，测试条件是dict（键）.strtest1 =＆＃34;绿色＆＃34;然后......）
3.68905对于带有索引的Next，对于i = 1到dict.count，设置o = dict（i）
4.16361与6相同但没有SET dict.items（i）.strTest1 =＆＃34; Green＆＃34;然后...
0.02192以及Tim William的回答

所以从这里我学到了永远不会迭代带有索引的字典。此外，直接处理对象（使用SET）比通过对集合或字典的引用访问更快。最快的方法是简单的FOR EACH obj IN Collection，NEXT obj循环。简单地遍历字典（FOR EACH键IN dict.keys，SET obj = dict（key），NEXT键）需要两倍多的时间（这是有道理的，因为每个循环都有额外的操作， SET功能）。虽然每个循环的税率是固定的，但如果你在循环期间进行多次操作（测试多个条件），这将变得不那么重要。威廉先生的方法可与每种关键方法相媲美。

好的，鉴于我只是重新运行测试迭代匹配函数（模拟我不仅仅是过滤，而是处理过滤后的选择的情况）。因此，如果我的标题失败，则应该读取方法编号，方法完成1个匹配操作的经过时间，每个方法所花费的时间长于1个匹配的最快方法的因子，方法完成50个匹配的经过时间操作，比基线多长的因素。

Method__1x（一个或多个）的因子（1×）__ 50X（S）_____因子（50X） 1 _______ 0.006 ____ 1 _________ 0.159 _______ 1__收集每个收集 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。威廉的回答

所以这加强了上面的答案形式。方程中的for-each循环，或dict.keys中的每个键，设置obj = dict（key），而William先生的答案在复杂性增长时同样有效。使用索引的影响会随着访问属性的次数而减少，但效率低于使用每种方法的效果。最后，当您直接访问类对象时，VBA更有效，而不是通过父集合/字典的引用访问它。也许除了我之外，这对每个人来说都是显而易见的，因为我没有编程背景并且正在学习，但是对我的直觉和经验法则进行量化是很好的。

我意识到此时我已经模糊了3个不同的问题。最快的过滤方式，最快的迭代方式，以及访问集合或字典中对象属性的最快方法。对不起，如果这个距离太远，我只是想通过阅读你的答案来分享我所学到的东西。

Answer 1

使用示例类使用300k对象进行测试。

编辑：更新了一点过滤灵活性。

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个属性中的每个属性的值而不仅仅是Tim演示中的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

VBA - 按属性

2 个答案:

类：clTest_Collection

模块1：公共模块