Sum rows based on cell value and then delete all duplicates

Question

I have an Excel Sheet where some rows may contain the same data as other rows. I need a macro to sum all the values in that column and delete all the duplicates rows, except for the first one, which contains the sum of the rest.

I have tried multiple versions of code and the code that produces the results closest to what I need looks like this, but this code contains one problem is: infinite loop.

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

After the first duplicate, you set `k = k-1`, doesn't that mean that j=k for the next loop? And what is the point of `k = k`? — Christofer Weber, Mar 18 '21 at 14:36
if two rows have the same value the code will delete the last row so that's why I set `K=K-1` I must to delete `K=K` — Sabrine Belkaid, Mar 18 '21 at 14:43

score 6 · Answer 1 · answered Mar 18 '21 at 14:58

I would recommend getting the data in an array and then do the relevant operation. This is a small range and it may not affect the performance but for a larger dataset it will matter.

Is this what you are trying?

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

Yes it's working , that's exactly what I'm looking for , Thank you @Siddarth_Rout — Sabrine Belkaid, Mar 18 '21 at 15:18

score 1 · Answer 2 · answered Mar 18 '21 at 15:11

1

If VBA isn't essential and you've got 365:

In cell G2 enter the formula =UNIQUE(A2:B11)
In cell I2 enter the formula =SUMIFS(C2:C11,A2:A11,INDEX(G2#,,1),B2:B11,INDEX(G2#,,2))

answered Mar 18 '21 at 15:11

Darren Bartrup-Cook

18,362
1
23
45

unfortunately, I have to use VBA, thank you – Sabrine Belkaid Mar 18 '21 at 15:21

VBasic2008 · Answer 3 · 2021-03-18T17:28:51.260

Remove Duplicates with Sum

Adjust the values in the constants section.
Note that if you choose the same worksheets and "A1", you will overwrite.

The Code

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

I am a beginner in VBA,and my knowledge in array and dictionary object is limited but your answer really helped me thank you so much — Sabrine Belkaid, Mar 26 '21 at 14:19

Sum rows based on cell value and then delete all duplicates

3 Answers3

Remove Duplicates with Sum