根據單元格值對行求和，然后刪除所有重復項

Question

我有一個 Excel 表，其中某些行可能包含與其他行相同的數據。 我需要一個宏來對該列中的所有值求和並刪除所有重復行，但第一個行除外，它包含 rest 的總和。

我嘗試了多個版本的代碼，產生最接近我需要的結果的代碼看起來像這樣，但是這段代碼包含一個問題是：無限循環。

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

Output

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