请求升级Excel VBA代码：去重Column K后汇总Column AE数值

以下是修改后的代码，实现按**A列和K列（客户编号）**判断重复项，汇总对应AE列的数值到每组首行，再删除其他重复行：

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    Application.ScreenUpdating = False ' 关闭屏幕刷新，提升运行效率
    
    Dim dataRng As Range, cell As Range
    Dim uniqueKey As String
    Dim sumDict As Object, deleteRows As Object
    Dim lastRow As Long, i As Long
    
    ' 定义数据范围：从A4到AE列最后一行（避免固定200行的限制）
    lastRow = Cells(Rows.Count, "K").End(xlUp).Row
    If lastRow < 4 Then GoTo Cleanup ' 没有数据时直接退出
    Set dataRng = Range("A4:AE" & lastRow)
    
    ' 初始化字典：存储唯一键对应的AE列总和与首行号
    Set sumDict = CreateObject("Scripting.Dictionary")
    Set deleteRows = CreateObject("Scripting.Dictionary")
    
    ' 遍历数据行，统计求和并标记重复行
    For i = dataRng.Rows.Count To 1 Step -1 ' 从下往上遍历，避免行号错乱
        uniqueKey = dataRng.Cells(i, 1).Value & "|" & dataRng.Cells(i, 11).Value ' A列+K列作为唯一键
        
        If sumDict.Exists(uniqueKey) Then
            ' 已存在该键：累加AE列值到首行，标记当前行待删除
            dataRng.Cells(sumDict(uniqueKey), 31).Value = dataRng.Cells(sumDict(uniqueKey), 31).Value + dataRng.Cells(i, 31).Value
            deleteRows.Add i + 3, True ' 因为dataRng从第4行开始，i是相对行号，实际行号是i+3
        Else
            ' 首次出现该键：记录首行号和初始AE值
            sumDict.Add uniqueKey, i
        End If
    Next i
    
    ' 批量删除重复行
    If deleteRows.Count > 0 Then
        Rows(Join(deleteRows.Keys, ",")).Delete Shift:=xlUp
    End If
    
    ' 设置居中对齐
    Columns("A:AE").HorizontalAlignment = xlCenter

Cleanup:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

关键修改说明 #

• 替换RemoveDuplicates逻辑：改用字典Scripting.Dictionary跟踪重复项，既保留每组首行的原始数据，又能对AE列（第31列）数值求和
• 唯一键判断：延续原代码逻辑，同时以A列和K列的值作为重复判断依据；若只需按K列判断重复，可将uniqueKey改为dataRng.Cells(i, 11).Value
• 批量删除行：从下往上遍历并标记待删除行，最后批量删除，避免直接删行导致的遍历索引错乱问题
• 动态数据范围：不再固定到200行，自动识别K列最后一行数据，适配不同数据量

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