Вложенные коллекции в классах 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 является подходящим, поскольку у языка нет другой конструкции для выхода из нескольких вложенных циклов.
Edit:
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