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

Question

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

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

Class2:
 -Property1
 -Property2
 -Collection of Class3

Class3:
 -Property1
 -Property2

首先，我填充Class1，Class2，但我只填充Class3键 - 而不是值。然后我必须返回并填充该值，这将导致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只是快速读取已存储的值，因此速度很快。 不幸的是，如果您有许多相同长度的密钥，这种方法将无济于事。 为此，我会考虑为您的Collection添加一个数字键，并根据它进行比较。 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 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789~!@#$%^&*()_+`-={}|:""<>?[]\;',./") 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