Scripting.Dictionary 的性能替代方案

Question

我正在用 Excel-VBA 编写一个带有几个按钮的管理器。

其中之一是使用另一个 Excel 文件（我称之为T）作为输入生成一个选项卡。

T的一些属性：

• ~90MB尺寸
• ~350K行
• 包含最近14 个月的销售额数据（无序）。
• 相关栏目：
  • year/month
  • 总金额
  • 卖家名称
  • 家庭产品
  • 客户名称
• 没有 id 列（如：cod-client、cod-vendor 等）

主要关系：

• 卖家向许多客户销售许多产品

我正在生成一个新的 Excel 选项卡，其中包含来自卖家分组的最后一个 year/month 中的 T 的数据。

重要提示：

• T 是唯一可用的输入/源。
• 如果两个或多个卖家向同一个客户销售相同的产品，total-money 应计入所有这些卖家。

---

这就够了，现在你知道我已经编码过了。

我的代码可以运行，但是，它需要大约 4 分钟的运行时间。

我已经使用较小的源（不大于2MB）编写了一些其他按钮，这些源在 5 秒内运行。

考虑到T 的大小，4 分钟的运行时间是可以接受的。

但我并不为此感到自豪，至少现在还没有。

---

我的代码主要是基于Scripting.Dictionary从T映射数据，然后我使用for each key in obj ... next key将分组数据设置到新创建的标签页。

我不确定，但这是我的想法：

• 如果N 是Scripting.Dictionary 中的总键，我需要在聚合total-money 之前检查obj.Exists(str)。它将运行N 字符串比较返回false。
• 类似地，当我执行Set seller = obj(seller_name) 时，它会运行最大N 字符串比较。

---

我想弄错我的想法。但如果我没记错的话，我减少此函数运行时间的下一步（也是最后的希望）是使用Tries编写我自己的类对象。

我明天才开始编码，我想要的只是确认我的方法是否正确，或者如果我的方法错误，我需要一些建议。

你有什么建议吗？提前致谢。

Answer 1

超出内存限制

简而言之：

• 主要问题是因为我使用了存储信息（预处理）的动态编程方法来缩短执行时间。
• 我的代码现在在~ 13 seconds 中运行。

---

有些东西是我们很难学到的。但我很高兴我找到了答案。

• 使用任务管理器，我可以看到我的代码达到了 100% 的内存使用率。
• 我上面提到的使用 Scripting.Dictionary 的 DP 方法确实快了 100%。
• 我上面提到的 DP 方法使用我自己的cls_trie 实现也达到了 100%，但比第一种要晚。
• 这解释了 ~4-5 min 与 ~2-3 min 上述尝试的总运行时间相比。
• 在任务管理器中，我还可以看到 CPU 使用率从未达到 2%。

解决方案很简单，我必须平衡 CPU 和内存的使用。

• 我将一些 DP 方法更改为简单的 for-loops 和 if-conditions。
• CPU 使用率现在达到~15%。
• 内存使用率现在达到~65%。
• 我知道这与每台机器的 CPU 和内存容量有关。但在客户端机器上，它现在也在不超过15 seconds 运行。

---

我创建了一个GitHub repository with my cls_trie implementation，并添加了一个带有示例用法的excel文件。

我是 excel-vba 世界的新手（现在使用它 4 个月）。可能有一些方法可以改进我的 cls_trie 实现，我愿意接受建议：

Option Explicit

Public Keys As Collection
Public Children As Variant
Public IsLeaf As Boolean

Public tObject As Variant
Public tValue As Variant

Public Sub Init()
    Set Keys = New Collection
    ReDim Children(0 To 255) As cls_trie
    IsLeaf = False

    Set tObject = Nothing
    tValue = 0
End Sub

Public Function GetNodeAt(index As Integer) As cls_trie
    Set GetNodeAt = Children(index)
End Function

Public Sub CreateNodeAt(index As Integer)
    Set Children(index) = New cls_trie
    Children(index).Init
End Sub

'''
'Following function will retrieve node for a given key,
'creating a entire new branch if necessary
'''
Public Function GetNode(ByRef key As Variant) As cls_trie
    Dim node As cls_trie
    Dim b() As Byte
    Dim i As Integer
    Dim pos As Integer

    b = CStr(key)
    Set node = Me

    For i = 0 To UBound(b) Step 2
        pos = b(i) Mod 256

        If (node.GetNodeAt(pos) Is Nothing) Then
            node.CreateNodeAt pos
        End If

        Set node = node.GetNodeAt(pos)
    Next

    If (node.IsLeaf) Then
        'already existed
    Else
        node.IsLeaf = True
        Keys.Add key
    End If

    Set GetNode = node
End Function

'''
'Following function will get the value for a given key
'Creating the key if necessary
'''
Public Function GetValue(ByRef key As Variant) As Variant
    Dim node As cls_trie
    Set node = GetNode(key)
    GetValue = node.tValue
End Function

'''
'Following sub will set a value to a given key
'Creating the key if necessary
'''
Public Sub SetValue(ByRef key As Variant, value As Variant)
    Dim node As cls_trie
    Set node = GetNode(key)
    node.tValue = value
End Sub

'''
'Following sub will sum up a value for a given key
'Creating the key if necessary
'''
Public Sub SumValue(ByRef key As Variant, value As Variant)
    Dim node As cls_trie
    Set node = GetNode(key)
    node.tValue = node.tValue + value
End Sub

'''
'Following function will validate if given key exists
'''
Public Function Exists(ByRef key As Variant) As Boolean
    Dim node As cls_trie
    Dim b() As Byte
    Dim i As Integer

    b = CStr(key)
    Set node = Me

    For i = 0 To UBound(b) Step 2
        Set node = node.GetNodeAt(b(i) Mod 256)

        If (node Is Nothing) Then
            Exists = False
            Exit Function
        End If
    Next

    Exists = node.IsLeaf
End Function

'''
'Following function will get another Trie from given key
'Creating both key and trie if necessary
'''
Public Function GetTrie(ByRef key As Variant) As cls_trie
    Dim node As cls_trie
    Set node = GetNode(key)

    If (node.tObject Is Nothing) Then
        Set node.tObject = New cls_trie
        node.tObject.Init
    End If

    Set GetTrie = node.tObject
End Function

在上面的代码中可以看到：

• 我没有实现任何删除方法，因为直到现在我才需要它。但这很容易实现。
• 我将自己限制为 256 个孩子，因为在这个项目中，我正在处理的文本基本上是小写和大写 [a-z] 字母和数字，并且两个文本映射到同一个分支节点的概率趋于零。李>

---

正如一位伟大的程序员所说，每个人都喜欢自己的代码，即使别人的代码美得让人不喜欢^[1]

我的结论

• 我可能永远不会再使用 Scripting.Dictionary，即使证明它可能比我的 cls_trie 实现更好。

谢谢大家的帮助。

Answer 2

我相信您已经找到了正确的解决方案，因为过去两年没有任何更新。

无论如何，我想提一下（也许它会帮助其他人）你的瓶颈不是字典或二叉树。如果您有足够的 RAM，即使有数百万行，内存中的处理速度也会非常快。

瓶颈通常是从工作表中读取数据并将其写回工作表。这里的数组非常有用。

只需将工作表中的数据读入 Variant Array。 您不必立即使用该数组。如果您使用字典更舒服，只需将所有数据从数组传输到字典并使用它。由于此过程完全在内存中进行，因此不必担心性能损失。

当您完成字典中的数据处理后，将字典中的所有数据放回数组中，然后将该数组一次性写入新的工作表中。

Worksheets("New Sheet").Range("A1").Value = MyArray

我很确定它只需要几秒钟