Excel VBA实现同标识键下时间序列静态数值的行标记及汇总需求

全程采用数组内存操作，相比拆分工作表方案内存占用降低90%以上，17000个唯一键+十万级行数据均可秒级处理，运行前会自动对源数据按「唯一键+季度」升序排序，保证同个键的时间序列顺序正确，避免比较错位。

前置准备 #

• 源数据放在名为Source的工作表中，首行为表头：A列=唯一标识键，B列=季度（支持标准日期或可识别的季度文本如2023Q1），C列=对应数值
• 调整Excel宏安全设置，允许运行VBA代码

完整VBA代码 #

Sub ProcessTimeSeries()
    Dim srcArr, resArr, sumArr
    Dim lastRow As Long, i As Long, dict As Object
    Dim currentKey As String, lastVal As Variant
    Dim hasUnchanged As Boolean, sumIdx As Long
    
    '关闭屏幕更新和自动计算，大幅提升运行速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set dict = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Worksheets("Source")
        '获取源数据最后一行行号
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        '读取全量源数据到数组，避免反复读写单元格
        srcArr = .Range("A1:C" & lastRow).Value
        '初始化标记列数组（对应源表D列）
        ReDim resArr(1 To UBound(srcArr, 1), 1 To 1)
        resArr(1, 1) = "连续不变标记" '标记列表头
        
        '先按「唯一键+季度」升序排序，保证时间序列顺序正确
        .Range("A1:C" & lastRow).Sort Key1:=.Range("A1"), Order1:=xlAscending, _
            Key2:=.Range("B1"), Order2:=xlAscending, Header:=xlYes
    End With
    
    '遍历数据生成标记，同时记录唯一键的连续值状态
    sumIdx = 1
    ReDim sumArr(1 To 100000, 1 To 2) '预留10万行汇总空间，可按需调整
    sumArr(1, 1) = "唯一标识键"
    sumArr(1, 2) = "是否存在连续不变"
    
    For i = 2 To UBound(srcArr, 1)
        currentKey = CStr(srcArr(i, 1))
        '判断是否为新的唯一标识键
        If Not dict.exists(currentKey) Then
            dict.Add currentKey, True
            resArr(i, 1) = "" '首个周期无前置数据，不标记
            lastVal = srcArr(i, 3)
            hasUnchanged = False
            '新增到汇总表
            sumIdx = sumIdx + 1
            sumArr(sumIdx, 1) = currentKey
        Else
            '同个键比较当前值和上一季度值
            If srcArr(i, 3) = lastVal Then
                resArr(i, 1) = "是"
                hasUnchanged = True
            Else
                resArr(i, 1) = ""
                lastVal = srcArr(i, 3)
            End If
            '更新该键的汇总状态
            sumArr(sumIdx, 2) = IIf(hasUnchanged, "是", "否")
        End If
    Next i
    
    '写回标记列到源表D列
    ThisWorkbook.Worksheets("Source").Range("D1:D" & lastRow).Value = resArr
    
    '生成汇总表
    Dim sumWs As Worksheet
    On Error Resume Next
    Set sumWs = ThisWorkbook.Worksheets("汇总表")
    If Err.Number <> 0 Then
        Set sumWs = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets("Source"))
        sumWs.Name = "汇总表"
    End If
    On Error GoTo 0
    sumWs.Cells.Clear
    sumWs.Range("A1:B" & sumIdx).Value = sumArr
    '自动调整列宽
    sumWs.Columns("A:B").AutoFit
    ThisWorkbook.Worksheets("Source").Columns("D").AutoFit
    
    '恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "处理完成，共处理" & dict.Count & "个唯一标识键", vbInformation
End Sub

注意事项 #

• 如果季度是自定义格式的特殊文本，可提前调整排序逻辑符合你需要的时间先后顺序
• 标记内容可自定义，把代码中resArr(i, 1) = "是"的"是"替换为你需要的标记即可
• 如果源数据工作表名称不是Source，修改代码中ThisWorkbook.Worksheets("Source")对应的名称即可
• 数据量超过10万行时，修改ReDim sumArr(1 To 100000, 1 To 2)中的数值为你的最大行数即可
• 运行前请备份原始数据，避免误操作导致数据丢失

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