优化25万行迭代的Excel Macro，避免卡顿无响应

问题背景 #

开发Excel宏/用户窗体时遇到性能瓶颈：1.5万行工作表运行约10分钟，期间Excel无响应；25万行工作表运行8小时仍未完成。需要提升宏效率，或至少让用户查看进度避免Excel锁定。

宏功能说明 #

业务规则：同一用户365天内不得分配同一任务。数据共47列、25万行用户信息，已按用户名、创建日期、任务排序。
宏逻辑：逐行检查，先确认是否为同一用户，再查找365天内的重复任务分配实例，标记对应行为红色，随后检查下一行与初始行是否也在365天内重复。

原宏代码 #

Sub highlight_newer_dates_v2()
    Dim i As Long, j As Long
    Dim lastRow As Long
    Dim AccountNo As String, SpecialtyTo As String, CreateDate1 As Date, CreateDate2 As Date
    Dim lastNonRedRow As Long
    lastRow = Cells(Rows.Count, "I").End(xlUp).Row
    lastNonRedRow = 0

    For i = 2 To lastRow
        AccountNo = Cells(i, 9).Value
        SpecialtyTo = Cells(i, 13).Value
        CreateDate1 = Cells(i, 5).Value
        If Cells(i, 9).Interior.Color = RGB(255, 0, 0) Then
            If lastNonRedRow = 0 Then
                For j = i - 1 To 2 Step -1
                    If Cells(j, 9).Interior.Color <> RGB(255, 0, 0) Then
                        lastNonRedRow = j
                        Exit For
                    End If
                Next j
            End If
            If lastNonRedRow <> 0 Then
                CreateDate1 = Cells(lastNonRedRow, 5).Value
            End If
        Else
            lastNonRedRow = i
        End If

        For j = i + 1 To lastRow
            If Cells(j, 9).Value = AccountNo And Cells(j, 13).Value = SpecialtyTo Then
                CreateDate2 = Cells(j, 5).Value
                If Abs(CreateDate2 - CreateDate1) <= 365 Then
                    If CreateDate2 > CreateDate1 Then
                        Rows(j).Interior.Color = RGB(255, 0, 0)
                    Else
                        Rows(i).Interior.Color = RGB(255, 0, 0)
                    End If
                End If
            End If
        Next j
    Next i
End Sub

解决方案 #

一、核心效率优化（从O(n²)降到O(n)） #

原代码嵌套两层循环，25万行时计算量达到数十亿级别，必然卡顿。利用数据已按用户名+任务+创建日期排序的特性，只需遍历一次，同一用户同一任务的记录是连续的，可大幅减少计算量：

1. 批量读取数据到数组：数组操作比直接读写单元格快1000倍以上，避免频繁和Excel交互。
2. 按分组处理：同一用户同一任务的记录连续，只需在组内对比当前行与前面的记录，一旦时间差超过365天，后面的记录时间差只会更大，直接跳出组内检查。
3. 关闭Excel后台操作：临时关闭屏幕刷新、事件触发和警告弹窗，减少UI开销。

优化后代码：

Sub highlight_duplicates_fast()
    Dim ws As Worksheet
    Dim dataArr As Variant, colorArr As Variant
    Dim lastRow As Long, i As Long, groupStart As Long, j As Long
    Dim currAccount As String, currSpecialty As String
    Dim currDate As Date
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
    
    ' 关闭后台操作提升速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    ' 批量读取所有数据到数组（覆盖47列）
    dataArr = ws.Range("A2:AN" & lastRow).Value
    ' 初始化颜色数组，默认无填充色
    ReDim colorArr(2 To lastRow, 1 To 47)
    For i = 2 To lastRow
        For j = 1 To 47
            colorArr(i, j) = xlColorIndexNone
        Next j
    Next i
    
    ' 初始化第一个分组
    groupStart = 2
    currAccount = dataArr(groupStart - 1, 9) ' 数组索引从1开始，对应行2是数组第1行
    currSpecialty = dataArr(groupStart - 1, 13)
    
    For i = 3 To lastRow
        ' 检查是否切换到新的用户-任务组
        If dataArr(i - 1, 9) <> currAccount Or dataArr(i - 1, 13) <> currSpecialty Then
            ' 处理上一个分组
            processGroup dataArr, colorArr, groupStart, i - 1
            ' 更新分组信息
            groupStart = i
            currAccount = dataArr(i - 1, 9)
            currSpecialty = dataArr(i - 1, 13)
        End If
    Next i
    ' 处理最后一个分组
    processGroup dataArr, colorArr, groupStart, lastRow
    
    ' 批量写入颜色设置到工作表
    ws.Range("A2:AN" & lastRow).Interior.ColorIndex = colorArr
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

' 处理同一用户-任务分组的子过程
Sub processGroup(dataArr As Variant, colorArr As Variant, startRow As Long, endRow As Long)
    Dim i As Long, j As Long
    Dim currDate As Date
    
    For i = startRow To endRow
        currDate = dataArr(i - 1, 5)
        ' 向前检查365天内的记录，日期排序后超过365天就停止
        For j = i - 1 To startRow Step -1
            If Abs(currDate - dataArr(j - 1, 5)) <= 365 Then
                ' 标记两行都为红色
                markRowRed colorArr, i
                markRowRed colorArr, j
            Else
                Exit For
            End If
        Next j
    Next i
End Sub

' 标记整行为红色的子过程
Sub markRowRed(colorArr As Variant, rowNum As Long)
    Dim j As Long
    For j = 1 To 47
        colorArr(rowNum, j) = 3 ' 3对应RGB(255,0,0)的ColorIndex
    Next j
End Sub

二、进度显示与避免Excel锁定 #

如果需要让用户看到进度，避免Excel显示无响应，可添加状态栏更新和事件处理：

在highlight_duplicates_fast的主循环中加入以下代码（每处理1000行更新一次）：

' 每处理1000行更新进度并释放资源
If i Mod 1000 = 0 Then
    Application.StatusBar = "处理进度：" & Format(i / lastRow, "0%") & " (" & i & "/" & lastRow & ")"
    DoEvents ' 让Excel响应系统事件，避免锁定
End If

循环结束后添加：

Application.StatusBar = False ' 恢复默认状态栏

额外优化建议 #

• 用条件格式替代宏：如果不需要动态运行宏，可直接设置条件格式规则：按用户名和任务分组，计算当前行与组内其他行的日期差，满足365天内重复则标记红色。
• 拆分大表：25万行数据建议拆分到多个工作表，或用Power Query预处理后再计算，减少单表压力。

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