Excel VBA优化：加速大数据集循环处理方案咨询

处理超20万行、50列的大数据集，其中一列包含案号，已提取到另一工作表并去重得到唯一值。需要为每个唯一案号查找原数据集多列的对应最大值，用于后续计算：

• 最初遍历唯一案号列表，用Application.MaxIfs函数处理原数据集，因频繁调用工作表导致循环速度极慢。
• 改用内存数组后仍需30分钟以上完成。
• 尝试过字典法，但无法适配实现最大值查找。
• 疑问：是否有更高效的实现方式？原代码的数组使用是否正确？

原代码片段 #

Sub Summarize_Data()
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim CaseRawRange As Variant
    Dim CaseUniqueRange As Variant
    Dim CalculationsArray as Variant
    Dim DateRange1 as Variant
    Dim DateRange2 as Variant
    Dim DateRange3 as Variant

    CaseRawRange = RawDataWorksheet.Range(RawDataWorksheet.Cells(1, CaseColumn), RawDataWorksheet.Cells(LastRowRawData, CaseColumn)).Value
    CaseUniqueRange = CalculationsWorksheet.Range(CalculationsWorksheet.Cells(1, 1), CalculationsWorksheet.Cells(RMACaseUniqueCount, 1)).Value
    DateRange1 = RawDataWorksheet.Range(RawDataWorksheet.Cells(1, DateColumn1), RawDataWorksheet.Cells(LastRowRawData, DateColumn1)).Value
    DateRange2 = RawDataWorksheet.Range(RawDataWorksheet.Cells(1, DateColumn2), RawDataWorksheet.Cells(LastRowRawData, DateColumn2)).Value
    DateRange3 = RawDataWorksheet.Range(RawDataWorksheet.Cells(1, DateColumn3), RawDataWorksheet.Cells(LastRowRawData, DateColumn3)).Value

    '查找每个唯一案号的最大日期值        
    For k = 2 To UniqueCaseCount
        MaxDate1 = 0
        MaxDate2 = 0
        MaxDate3 = 0
                For h = 2 To LastRowRawData
                    If CaseUniqueRange(k, 1) = CaseRawRange(h, 1) And DateRange1(h, 1) > MaxDate1 Then
                    MaxDate1 = DateRange1(h, 1)
                    Else
                    MaxDate1 = MaxDate1
                    End If

                    If CaseUniqueRange(k, 1) = CaseRawRange(h, 1) And DateRange2(h, 1) > MaxDate2 Then
                    MaxDate2 = DateRange2(h, 1)
                    Else
                    MaxDate2 = MaxDate2
                    End If

                    If CaseUniqueRange(k, 1) = CaseRawRange(h, 1) And DateRange3(h, 1) > MaxDate3 Then
                    MaxDate3 = DateRange3(h, 1)
                    Else
                    MaxDate3 = MaxDate3
                    End If
                Next h

            '基于最大日期值执行指标计算
            If MaxDate1 = 0 Or MaxDate1 > MaxDate2 Then
                CalculationsArray(k, 2) = "FALSE"
            Else
                CalculationsArray(k, 2) = "TRUE"
            End If

            If MaxDate2 = MaxDate3 Or MaxDate3 = 0 Then
                CalculationsArray(k, 3) = "FALSE"
            Else
                CalculationsArray(k, 3) = "TRUE"
            End If

            If MaxDate1 > MaxDate3 Then
                CalculationsArray(k, 4) = "FALSE"
            Else
                CalculationsArray(k, 4) = "TRUE"
            End If

    Next k

    '将计算数组粘贴到工作表
    CalculationsWorksheet.Range("B2").Resize(UBound(CalculationsArray, 1) - 1, UBound(CalculationsArray, 2)).Value = CalculationsArray

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

1. 原代码的核心问题 #

你把数据读到内存数组的操作是正确的，但嵌套循环的时间复杂度为O(N*M)（N是唯一案号数，M是原始数据行数），20万行数据搭配几万唯一案号时，运算量会达到数亿次，这是速度慢的根本原因。

2. 最优方案：字典+单次遍历原始数据 #

只需要遍历一次原始数据，用字典记录每个案号对应的三个日期最大值，之后直接用字典匹配唯一案号生成结果，时间复杂度降到O(M)，20万行数据几秒就能处理完。

实现代码 #

Sub Fast_Summarize_Data()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Dim rawData As Variant
    Dim uniqueCases As Variant
    Dim caseDict As Object
    Dim i As Long
    Dim caseID As String
    Dim maxDates As Variant

    '一次性读取包含案号+三个日期的整块数据，减少内存操作
    rawData = RawDataWorksheet.Range(RawDataWorksheet.Cells(1, 1), _
        RawDataWorksheet.Cells(LastRowRawData, DateColumn3)).Value

    '读取唯一案号列表
    uniqueCases = CalculationsWorksheet.Range(CalculationsWorksheet.Cells(1, 1), _
        CalculationsWorksheet.Cells(RMACaseUniqueCount, 1)).Value

    '初始化字典：键为案号，值为存储三个最大日期的数组
    Set caseDict = CreateObject("Scripting.Dictionary")
    caseDict.CompareMode = vbTextCompare '不区分大小写，按需修改

    '单次遍历原始数据，更新每个案号的最大日期
    For i = 2 To UBound(rawData, 1)
        caseID = rawData(i, CaseColumn)
        If caseDict.Exists(caseID) Then
            maxDates = caseDict(caseID)
            If rawData(i, DateColumn1) > maxDates(0) Then maxDates(0) = rawData(i, DateColumn1)
            If rawData(i, DateColumn2) > maxDates(1) Then maxDates(1) = rawData(i, DateColumn2)
            If rawData(i, DateColumn3) > maxDates(2) Then maxDates(2) = rawData(i, DateColumn3)
            caseDict(caseID) = maxDates
        Else
            caseDict(caseID) = Array(rawData(i, DateColumn1), rawData(i, DateColumn2), rawData(i, DateColumn3))
        End If
    Next i

    '初始化结果数组
    ReDim CalculationsArray(1 To UBound(uniqueCases, 1), 1 To 4)
    '填充案号列
    For i = 1 To UBound(uniqueCases, 1)
        CalculationsArray(i, 1) = uniqueCases(i, 1)
    Next i

    '根据字典生成计算结果
    For i = 2 To UBound(CalculationsArray, 1)
        caseID = CalculationsArray(i, 1)
        If caseDict.Exists(caseID) Then
            maxDates = caseDict(caseID)
            CalculationsArray(i, 2) = IIf(maxDates(0) = 0 Or maxDates(0) > maxDates(1), "FALSE", "TRUE")
            CalculationsArray(i, 3) = IIf(maxDates(1) = maxDates(2) Or maxDates(2) = 0, "FALSE", "TRUE")
            CalculationsArray(i, 4) = IIf(maxDates(0) > maxDates(2), "FALSE", "TRUE")
        Else
            '处理原始数据中不存在的案号（可选逻辑）
            CalculationsArray(i, 2) = "FALSE"
            CalculationsArray(i, 3) = "FALSE"
            CalculationsArray(i, 4) = "FALSE"
        End If
    Next i

    '写入结果到工作表
    CalculationsWorksheet.Range("A2").Resize(UBound(CalculationsArray, 1) - 1, UBound(CalculationsArray, 2)).Value = CalculationsArray

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

    Set caseDict = Nothing
End Sub

3. 额外优化建议 #

• 一次性读取整块数据：避免单独读取每一列，减少内存分配次数。
• 关闭EnableEvents：防止触发工作表事件拖慢速度。
• 早期绑定字典：添加Microsoft Scripting Runtime引用，将CreateObject("Scripting.Dictionary")改为New Dictionary，进一步提升速度。
• 用数字作为字典键：如果案号是数字类型，直接用数字作为键，比字符串匹配更快。

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