Vba remove duplicate and sum value

Question

I am trying to remove duplicate rows and sum their value.
Example:

Results:

I want to combine them so that I can compare this value with another database.

Sub mcrCombineAndScrubDups()
    For Each a In Range("A1", Cells(Rows.Count, "A").End(xlUp))
        For r = 1 To Cells(Rows.Count, "A").End(xlUp).Row - a.Row
            If a = a.Offset(r, 0) And a.Offset(0, 1) = a.Offset(r, 1) Then
                a.Offset(0, 4) = a.Offset(0, 4) + a.Offset(r, 4)
                a.Offset(r, 0).EntireRow.Delete
                r = r - 1
            End If
        Next r
    Next a
End Sub

What is working, what isn't working and why are we "printing" stuff in E? — Christofer Weber
– Christofer Weber, Commented Oct 20, 2020 at 12:51
99 times out of 100, you're better off deleting from the bottom up rather than using an artificial counter (r in your case). Also, depending on your data, you should look in to using the built in .RemoveDuplicate function on the range is it will be much faster. — sous2817
– sous2817, Commented Oct 20, 2020 at 13:02
Just use a Pivot Table. In Tabular form, with no subtotals or totals, it will mimic what you show for results — Ron Rosenfeld
– Ron Rosenfeld, Commented Oct 20, 2020 at 18:43

Christofer Weber · Accepted Answer · 2020-10-22 11:43:46Z

1

One way to do it, if we want to stick with the nested loop approach is the following:
First I make sure that the cell isn't empty, because checking empty cells is a waste of time.
Then I go through the range and note every duplicate row and its value in column 3.
Then add the value to our original row, and delete all the duplicates in one go, to keep the writing to the document to a minimum.

Sub mcrCombineAndScrubDups()
Dim searchRange As Long, deleteRange As Range, addValue As Long
searchRange = Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To searchRange
        If Not Cells(i, 1) = "" Then
            Set deleteRange = Nothing
            addValue = 0
            For j = i + 1 To searchRange
                If Cells(j, 1) = Cells(i, 1) And Cells(j, 2) = Cells(i, 2) And Not Cells(j, 1) = "" Then
                    If deleteRange Is Nothing Then
                        Set deleteRange = Cells(j, 1)
                    Else
                        Set deleteRange = Union(deleteRange, Cells(j, 1))
                    End If
                    addValue = addValue + Cells(j, 3)
                End If
            Next j
            If addValue > 0 Then Cells(i, 3) = Cells(i, 3) + addValue
            If Not deleteRange Is Nothing Then deleteRange.EntireRow.Delete
        End If
    Next i
End Sub

Scrapped the old code that could only do a sorted list, and was slower.

EDIT

Made a dictionary approach, which is a lot faster, incorporating suggestions from the comments.

Sub mcrCombineAndScrubDups()
Dim dict As Object, i As Long, dKey As String
Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    dKey = (Cells(i, 1) & " " & Cells(i, 2))
    dict(dKey) = Cells(i, 3) + dict(dKey)
Next i
    
Range(Range("A1"), Range("C" & Rows.Count).End(xlUp)).RemoveDuplicates Columns:=Array(1, 2)

For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    dKey = (Cells(i, 1) & " " & Cells(i, 2))
    If Not Cells(i, 3) = dict(dKey) Then Cells(i, 3) = dict(dKey)
Next i

End Sub

edited Oct 22, 2020 at 11:43

answered Oct 20, 2020 at 13:00

Christofer Weber

1,4741 gold badge10 silver badges18 bronze badges

Sign up to request clarification or add additional context in comments.

8 Comments

Vityata Over a year ago

What would happen if the last line and the first line are equal on the input of the OP?

Christofer Weber Over a year ago

@Vityata It would get deleted. Using this on an empty sheet will cause an infinite loop though. Added a small fix for that.

Christofer Weber Over a year ago

@Vityata Oh, you meant like that. Yeah this obviously only works in a sorted list like the example. I was just modifying his code to work with what he was trying to do. Sorry about that.

Vityata Over a year ago

It's never a waste of time, if you are having fun :)

Christofer Weber Over a year ago

@Vityata Always fun with a challenge and to learn something new. Made a dictionary version now. Should be the bare minimum of sheet interaction. Suggestions welcome.

|

Collectives™ on Stack Overflow

Vba remove duplicate and sum value

1 Answer 1

8 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

8 Comments

Your Answer

Sign up or log in

Post as a guest

Related