根据单元格值对行求和，然后删除所有重复项

Question

我有一个 Excel 表，其中某些行可能包含与其他行相同的数据。我需要一个宏来对该列中的所有值求和并删除所有重复的行，但第一个行除外，它包含其余行的总和。

我尝试了多个版本的代码，产生最接近我需要的结果的代码看起来像这样，但是这个代码包含一个问题是：无限循环。

Sub delet()
    Dim b As Integer
    Dim y As Worksheet
    Dim j As Double
    Dim k As Double

    Set y = ThisWorkbook.Worksheets("Sheet1")
    b = y.Cells(Rows.Count, 2).End(xlUp).Row

    For j = 1 To b
        For k = j + 1 To b
            If Cells(j, 2).Value = Cells(k, 2).Value Then
                Cells(j, 3).Value = (Cells(j, 3).Value + Cells(k, 3).Value)
                Rows(k).EntireRow.Delete
                k = k - 1
            ElseIf Cells(j, 2).Value <> Cells(k, 2).Value Then
                k = k
            End If
        Next
    Next
End Sub

Answer 1

我建议将数据放入数组中，然后进行相关操作。这是一个很小的范围，它可能不会影响性能，但对于更大的数据集，它会很重要。

这是你正在尝试的吗？

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long, i As Long, j As Long
    Dim MyAr As Variant, outputAr As Variant
    Dim col As New Collection
    Dim itm As Variant
    Dim totQty As Double
    
    '~~> Change this to the relevant sheet
    Set ws = Sheet1
    
    With ws
        '~~> Find last row of col A
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        '~~> Get those value in an array
        MyAr = .Range("A2:C" & lRow).Value2
        
        '~~> Get unique collection of Fam.
        For i = LBound(MyAr) To UBound(MyAr)
            If Len(Trim(MyAr(i, 2))) <> 0 Then
                On Error Resume Next
                col.Add MyAr(i, 2), CStr(MyAr(i, 2))
                On Error GoTo 0
            End If
        Next i
        
        '~~> Prepare array for output
        ReDim outputAr(1 To col.Count, 1 To 3)
        
        i = 1
        
        For Each itm In col
            '~~> Get Product
            For j = LBound(MyAr) To UBound(MyAr)
                If MyAr(i, 2) = itm Then
                    outputAr(i, 1) = MyAr(i, 1)
                    Exit For
                End If
            Next j
            
            '~~> Fam.
            outputAr(i, 2) = itm
            
            totQty = 0
            
            '~~> Qty
            For j = LBound(MyAr) To UBound(MyAr)
                If MyAr(j, 2) = itm Then
                    totQty = totQty + Val(MyAr(j, 3))
                End If
            Next j
            
            outputAr(i, 3) = totQty
            
            i = i + 1
        Next itm
        
        '~~> Copy headers
        .Range("A1:C1").Copy .Range("G1")
        '~~> Write array to relevant range
        .Range("G2").Resize(UBound(outputAr), 3).Value = outputAr
    End With
End Sub

输出

Answer 2

如果 VBA 不是必需的并且您拥有 365：

在单元格G2 中输入公式=UNIQUE(A2:B11)
在单元格I2 中输入公式=SUMIFS(C2:C11,A2:A11,INDEX(G2#,,1),B2:B11,INDEX(G2#,,2))

Answer 3

使用 Sum 删除重复项

• 调整常量部分中的值。
• 请注意，如果您选择相同的工作表和"A1"，则会覆盖。

守则

Option Explicit

Sub removeDupesSum()
    
    Const sName As String = "Sheet1"
    Const dName As String = "Sheet1"
    Const dFirst As String = "G1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Write values from Source Range to Data Array.
    Dim Data As Variant
    Data = wb.Worksheets(sName).Cells(1).CurrentRegion.Value
    
    ' Write unique values from Data Array to Unique Sum Dictionary.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim arr As Variant: ReDim arr(2 To UBound(Data, 1)) ' for first column
    Dim n As Long: n = 1
    Dim i As Long
    For i = 2 To UBound(Data, 1)
        If dict.Exists(Data(i, 2)) Then
            dict(Data(i, 2)) = dict(Data(i, 2)) + Data(i, 3)
        Else
            n = n + 1
            arr(n) = Data(i, 1)
            dict(Data(i, 2)) = Data(i, 3)
        End If
    Next i
    
    Dim Result As Variant: ReDim Result(1 To dict.Count + 1, 1 To 3)
    ' Write headers.
    For i = 1 To 3
        Result(1, i) = Data(1, i)
    Next i
    Erase Data
    ' Write 'body'.
    Dim Key As Variant
    i = 1
    For Each Key In dict.Keys
        i = i + 1
        Result(i, 1) = arr(i)
        Result(i, 2) = Key
        Result(i, 3) = dict(Key)
    Next Key
    
    ' Write values from Result Array to Destination Range.
    With wb.Worksheets(dName).Range(dFirst).Resize(, 3)
        .Resize(i).Value = Result
        .Resize(.Worksheet.Rows.Count - .Row - i + 1).Offset(i).ClearContents
    End With

End Sub