VBA类中导致性能问题的嵌套集合

Question

我遇到了VBA的性能问题，这可能与我如何构建我的OO模型有关，但表现为使用集合的性能降低。

Class1: 
-Property1 
-Collection of Class2 
+GetClass2ByClass3Property1(Class3Property1) 

Class2: 
-Property1 
-Property2 
-Collection of Class3 

Class3: 
-Property1 
-Property2 

首先，我填充Class1，Class2，但我只填充Class3 Key - 不是值。然后，我要回去和填充值，这导致功能class1的是这样的：

For i=1 to Class1Collection.Count 
For j=1 to Class1Collection(i).Count 
    If (Class1Collection.Item(i).Item(j) = myComparisonValue) Then 
     Set myReturnValue = Class1Collection.Item(i).Item(j) 
     Exit For 
    End If 
    Next j 
Next i 

这个嵌套循环的表现很糟糕。

我是否需要用数组替换所有集合？如果是这样，任何建议如何做到最少侵入性。

Answer 1

我觉得这里的问题是可能的

Class1Collection.Item(i).Item(j) = myComparisonValue 

有一对夫妇的方法来优化字符串比较比较。最便宜的方式做到这一点不完全重组的对象模型是做这样的事情：

Dim myComparisonValue As Long 
myComparisonValue = Len(myComparisonValue) 
For i = 1 To Class1Collection.Count 
    For j = 1 To Class1Collection(i).Count 
     If Len(Class1Collection.Item(i).Item(j)) = myComparisonValue Then 
      If (Class1Collection.Item(i).Item(j) = myComparisonValue) Then 
       Set myReturnValue = Class1Collection.Item(i).Item(j) 
       Exit For 
      End If 
     End If 
    Next j 
Next i 

的原因，这是（往往）要快，因为比较字符串慢。 Len只是快速读取已存储的值，因此速度很快。 不幸的是，这种方法在您有许多长度相同的密钥的情况下无效。 为此，我会考虑在您的收藏夹中添加一个数字键，并根据此数据进行比较。 ObjPtr函数是获取唯一密钥的廉价方法。

我还注意到，您的退出只是打破了你的内部循环。这可能是Goto适合的罕见场合之一，因为该语言没有其他构造用于退出多个嵌套循环。
编辑：
UDT例新增

Option Explicit 

Private Declare Function GetTickCount Lib "kernel32"() As Long 

Private Type ThingAMaBob 
    Key As Long 
    Text As String 
End Type 

Private Type ThingAMaBobs 
    UpperBound As Long 
    Items() As ThingAMaBob 
End Type 

Private Type ThingAMaBobsCollection 
    UpperBound As Long 
    Items() As ThingAMaBobs 
End Type 


Private Sub Test() 
    Const xMax As Long = 1000& 
    Const yMax As Long = 1000& 
    Dim udtCol As ThingAMaBobsCollection 
    Dim stTime As Long 
    Dim endTime As Long 
    Dim seekValue As String 
    Dim seekKey As String 
    Dim x As Long 
    Dim y As Long 
    stTime = GetTickCount 
    udtCol = CreateUDT(xMax, yMax) 
    endTime = GetTickCount 
    Debug.Print "Milliseconds to fill", endTime - stTime 

    x = xMax \ 2& 
    y = yMax \ 2& 
    seekValue = udtCol.Items(x).Items(y).Text 

    stTime = GetTickCount 
    seekKey = SeekKeyByValue(udtCol, seekValue, True) 
    endTime = GetTickCount 
    Debug.Print "Milliseconds to get key by value", endTime - stTime 

    stTime = GetTickCount 
    seekValue = SeekValueByKey(udtCol, seekKey) 
    endTime = GetTickCount 
    Debug.Print "Milliseconds to get value by key", endTime - stTime 

End Sub 

Private Function CreateUDT(ByVal xMax As Long, ByVal yMax As Long) As ThingAMaBobsCollection 
    Dim rtnVal As ThingAMaBobsCollection 
    Dim x As Long, y As Long 
    xMax = xMax - 1& 
    yMax = yMax - 1& 
    With rtnVal 
     .UpperBound = xMax 
     ReDim .Items(.UpperBound) 
     For x = 0& To xMax 
      With .Items(x) 
       .UpperBound = yMax 
       ReDim .Items(.UpperBound) 
       For y = 0& To yMax 
        .Items(y).Text = RandomString(RndBetween(8&, 16&)) 
        .Items(y).Key = StrPtr(.Items(y).Text) 
       Next 
      End With 
     Next 
    End With 
    CreateUDT = rtnVal 
End Function 

Private Function SeekKeyByValue(ByRef col As ThingAMaBobsCollection, ByVal seekValue As String, ByVal compareCase As Boolean) 
    Dim x As Long 
    Dim y As Long 
    Dim seekLen As Long 
    Dim rtnVal As Long 
    seekLen = Len(seekValue) 
    If compareCase Then 
     For x = 0& To col.UpperBound 
      For y = 0& To col.Items(x).UpperBound 
       If Len(col.Items(x).Items(y).Text) = seekLen Then 
        If col.Items(x).Items(y).Text = seekValue Then 
         rtnVal = col.Items(x).Items(y).Key 
        End If 
       End If 
      Next 
     Next 
    Else 
     seekValue = LCase$(seekValue) 
     For x = 0& To col.UpperBound 
      For y = 0& To col.Items(x).UpperBound 
       If Len(col.Items(x).Items(y).Text) = seekLen Then 
        If LCase$(col.Items(x).Items(y).Text) = seekValue Then 
         rtnVal = col.Items(x).Items(y).Key 
        End If 
       End If 
      Next 
     Next 
    End If 
    SeekKeyByValue = seekLen 
End Function 

Private Function SeekValueByKey(ByRef col As ThingAMaBobsCollection, ByVal seekKey As Long) As String 
    Dim x As Long 
    Dim y As Long 
    Dim rtnVal As String 
    For x = 0& To col.UpperBound 
     For y = 0& To col.Items(x).UpperBound 
      If col.Items(x).Items(y).Key = seekKey Then 
       rtnVal = col.Items(x).Items(y).Key 
      End If 
     Next 
    Next 
    SeekValueByKey = rtnVal 
End Function 

Private Function RandomString(ByVal Length As Long, Optional ByVal charset As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz~!@#$%^&*()_+`-={}|:""<>?[]\;',./") As String 
    Dim chars() As Byte, value() As Byte, chrUprBnd As Long, i As Long 
    If Length > 0& Then 
     Randomize 
     chars = charset 
     chrUprBnd = Len(charset) - 1& 
     Length = (Length * 2&) - 1& 
     ReDim value(Length) As Byte 
     For i = 0& To Length Step 2& 
      value(i) = chars(CLng(chrUprBnd * Rnd) * 2&) 
     Next 
    End If 
    RandomString = value 
End Function 

Private Function RndBetween(ByVal UpperBound As Long, ByVal lowerbound As Long) As Long 
    VBA.Math.Randomize 
    RndBetween = Int((UpperBound - lowerbound + 1) * Rnd + lowerbound) 
End Function