VBA大容量数组双循环匹配汇总运行缓慢问题寻求优化方案

核心问题分析 #

你当前的嵌套循环时间复杂度为O(nm)，8万条唯一值匹配60万条源数据累计需要执行480亿次条件判断，是耗时过长的根本原因。优化核心是将嵌套遍历匹配改为字典O(1)查找*，总时间复杂度直接降低到O(n+m)，仅需遍历68万次即可完成全部运算。

前置修正 #

你提供的前置代码存在笔误，转存唯一数组时Splittad应为Splitted，避免运行报错：

'原错误行
Array2(0, i - 1) = Splittad(0)
Array2(2, i - 1) = Splittad(1)
'修正后
Array2(0, i - 1) = Splitted(0)
Array2(2, i - 1) = Splitted(1)

具体优化代码 #

直接替换你原来的嵌套循环部分即可：

'可选：提前关闭无关设置进一步提速，运算结束后再恢复
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'1、构建汇总字典，后期绑定无需额外引用，兼容所有Office版本
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim key As String, tempArr As Variant

'2、仅遍历一次60万条源数组，预汇总所有键对应的数值
For ii = 0 To UBound(Array2, 2) '此处Array2为你60万行的源数据数组
    key = Array2(27, ii) & "¤" & Array2(20, ii)
    If Not dict.Exists(key) Then
        '首次出现该键，存入对应固定值和初始汇总值
        dict(key) = Array(Array2(21, ii), Array2(25, ii), Array2(24, ii))
    Else
        '已存在该键，仅累加数值字段
        tempArr = dict(key)
        tempArr(2) = tempArr(2) + Array2(24, ii)
        dict(key) = tempArr
    End If
Next ii

'3、仅遍历一次8万条唯一数组，直接查字典赋值
For i = 0 To UBound(Array1, 2) '此处Array1为你8万条的唯一值数组
    key = Array1(0, i) & "¤" & Array1(2, i)
    If dict.Exists(key) Then
        tempArr = dict(key)
        Array1(1, i) = tempArr(0)
        Array1(3, i) = tempArr(1)
        Array1(4, i) = tempArr(2)
    End If
Next i

'释放对象
Set dict = Nothing

'恢复原有设置
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

额外提速建议 #

• 如果对兼容性要求不高，可将字典改为前期绑定：在VBA编辑器点击「工具-引用」，勾选「Microsoft Scripting Runtime」，然后将Dim dict As Object改为Dim dict As Dictionary，运行速度会再提升10%-20%。
• 组合键的分隔符¤可以替换为任意不会出现在键值中的特殊字符，避免键重复碰撞。

内容的提问来源于stack exchange，提问作者ErikS