Excel VBA宏需求：保留Sheet1数据，按规则去重并求和

我来帮你调整这段VBA代码，让它同时实现你要的两个需求：A-C列内容重复时合并E、F列求和，A-D列内容重复时直接删除重复行。咱们先理清楚原代码的问题：你之前先对Sheet2做了A-D去重，但后面又把Sheet1处理后的字典数据直接写入Sheet2，相当于覆盖了之前的操作；而且核心的字典逻辑只用到了A-C列作为键，没考虑A-D列的去重要求。

准备工作：Class1模块内容 #

首先确保你已经创建了名为Class1的类模块，内容如下（如果还没创建，直接新建一个Class模块并粘贴这段代码）：

Public Col1 As Variant
Public Col2 As Variant
Public Col3 As Variant
Public Col4 As Variant
Public Col5 As Double
Public Col6 As Double

修改后的完整按钮点击代码 #

Private Sub CommandButton1_Click()
    Dim x As Long, arr As Variant, lst As Class1
    Dim dictAD As Object, dictAC As Object
    Dim tempArr() As Variant, tempIndex As Long
    
    ' 初始化两个字典：一个处理A-D去重，一个处理A-C求和合并
    Set dictAD = CreateObject("Scripting.Dictionary")
    Set dictAC = CreateObject("Scripting.Dictionary")
    
    ' 读取Sheet1的所有原始数据（不修改原表）
    With Sheet1
        x = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("A1:F" & x).Value
    End With
    
    ' 第一步：先处理A-D列去重，只保留每个A-D组合的第一行数据
    tempIndex = 0
    ReDim tempArr(1 To UBound(arr), 1 To 6)
    For x = LBound(arr) To UBound(arr)
        ' 用A-D列的内容组合作为字典键
        Dim keyAD As String
        keyAD = arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3) & "|" & arr(x, 4)
        
        If Not dictAD.Exists(keyAD) Then
            dictAD.Add keyAD, True
            tempIndex = tempIndex + 1
            ' 将该行数据存入临时数组
            For col = 1 To 6
                tempArr(tempIndex, col) = arr(x, col)
            Next col
        End If
    Next x
    ' 调整临时数组为实际有效行数
    ReDim Preserve tempArr(1 To tempIndex, 1 To 6)
    
    ' 第二步：对A-D去重后的数据，处理A-C列的求和合并
    For x = LBound(tempArr) To UBound(tempArr)
        Dim keyAC As String
        keyAC = tempArr(x, 1) & "|" & tempArr(x, 2) & "|" & tempArr(x, 3)
        
        If Not dictAC.Exists(keyAC) Then
            Set lst = New Class1
            lst.Col1 = tempArr(x, 1)
            lst.Col2 = tempArr(x, 2)
            lst.Col3 = tempArr(x, 3)
            lst.Col4 = tempArr(x, 4)
            lst.Col5 = tempArr(x, 5)
            lst.Col6 = tempArr(x, 6)
            dictAC.Add keyAC, lst
        Else
            ' 合并E、F列的数值
            dictAC(keyAC).Col5 = dictAC(keyAC).Col5 + tempArr(x, 5)
            dictAC(keyAC).Col6 = dictAC(keyAC).Col6 + tempArr(x, 6)
        End If
    Next x
    
    ' 第三步：清空Sheet2并写入最终处理结果
    With Sheet2
        .Cells.Clear
        x = 1
        ' 写入表头（保留原数据的表头格式）
        .Cells(x, 1).Value = arr(1, 1)
        .Cells(x, 2).Value = arr(1, 2)
        .Cells(x, 3).Value = arr(1, 3)
        .Cells(x, 4).Value = arr(1, 4)
        .Cells(x, 5).Value = arr(1, 5)
        .Cells(x, 6).Value = arr(1, 6)
        x = x + 1
        
        ' 写入处理后的内容
        For Each Key In dictAC.Keys
            .Cells(x, 1).Value = dictAC(Key).Col1
            .Cells(x, 2).Value = dictAC(Key).Col2
            .Cells(x, 3).Value = dictAC(Key).Col3
            .Cells(x, 4).Value = dictAC(Key).Col4
            .Cells(x, 5).Value = dictAC(Key).Col5
            .Cells(x, 6).Value = dictAC(Key).Col6
            x = x + 1
        Next Key
    End With
    
    ' 释放对象，避免内存占用
    Set dictAD = Nothing
    Set dictAC = Nothing
    Set lst = Nothing
End Sub

代码逻辑说明 #

• A-D列去重：先用字典dictAD过滤掉A-D列重复的行，只保留每个组合的第一行，存入临时数组，确保后续处理的都是A-D唯一的数据。
• A-C列求和合并：再用字典dictAC对临时数组中的数据处理A-C列重复，遇到相同的A-C组合就把E、F列的数值相加合并。
• 结果写入：最后清空Sheet2，先写入原数据的表头，再把处理后的结果逐行写入，全程不会修改Sheet1的原始数据。

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