Search code examples
excelvbasumduplicates

SUM values in one col based on rows with same values in another col and leave one row

I have cells values like image below

enter image description here

I need to transform with VBA code like image below

enter image description here

SUM QTY on col3 based on code from col1 where I have same value.

Thank you.

Dim LastRow1 As Long
With ActiveSheet
    LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Dim cc As Integer
For cc = 2 To LastRow1
    If Cells(cc, 1).Value = Cells(cc - 1, 1).Value Then
        Range("C:C").NumberFormat = "0"
        Rows(cc + 1).Insert Shift:=xlShiftDown
        Range("C" & cc + 1).Value = "=Sum(C" & cc & ", C" & cc - 1 & ")"
        Cells(cc + 1, 3).Value = Cells(cc + 1, 3).Value
        
        Cells(cc, 1).Select
        Selection.Copy
        Cells(cc + 1, 1).PasteSpecial Paste:=xlPasteValues
        
        Cells(cc, 2).Select
        Selection.Copy
        Cells(cc + 1, 2).PasteSpecial Paste:=xlPasteValues
        
        Cells(cc, 4).Select
        Selection.Copy
        Cells(cc + 1, 4).PasteSpecial Paste:=xlPasteValues          
        
        Rows(cc).EntireRow.Delete
        Rows(cc - 1).EntireRow.Delete
    End If
Next cc
Solution

  • Please, use the next code. It uses a dictionary to extract the unique keys, cumulate the values in the third columns and build a Union range (for the same keys, except the first occurrence) to delete the unnecessary rows, at the end. The code only selects the rows in discussion. If processing works well, you should replace in the last code line Select with Delete:

    Sub MergeValues()
   Dim sh As Worksheet, lastR As Long, arr, arrIt, i As Long, Rngdel As Range, dict As Object
   
   Set sh = ActiveSheet 'use here the sheet you need
   lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
   
   arr = sh.Range("A2:C" & lastR).Value2 'place the range in an array, for aster iteration/processing
   
   Set dict = CreateObject("Scripting.Dictionary") 'set the necessary dictionary
   For i = 1 To UBound(arr)  'iterate between the array rows
        If Not dict.exists(arr(i, 1)) Then
            dict.Add arr(i, 1), Array(i, arr(i, 3)) 'add the code as key, then the array row number (to adapt) and value of third column
        Else
            arrIt = dict(arr(i, 1))  'extract the dictionary item array
            arrIt(1) = arrIt(1) + arr(i, 3)
            dict(arr(i, 1)) = arrIt 'place back the processed array
            addToRange Rngdel, sh.Range("A" & i + 1)
        End If
   Next i
   
   'update the array with cumulated quantities
   For i = 0 To dict.count - 1
        arr(dict.Items()(i)(0), 3) = dict.Items()(i)(1)
   Next i
   
   'drop the updated array content:
   sh.Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value2 = arr
   
   If Not Rngdel Is Nothing Then Rngdel.EntireRow.Select 'if it processed correctly, you should replace here Select with Delete
End Sub

Private Sub addToRange(rngU As Range, rng As Range) 'function to create the Union range (to delete the necessary rows)
    If rngU Is Nothing Then
        Set rngU = rng
    Else
        Set rngU = Union(rngU, rng)
    End If
End Sub