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

Answer 1

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