Sum rows based on cell value and then delete all duplicates - excel

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

Answer 2

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))

Answer 3

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