CODEWITHSUNDEEP
excelvba
Sng Nick
Sng Nick

Reputation: 1

Vba remove duplicate and sum value

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

example


Results:

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

Upvotes: 0

Views: 900

Answers (1)

Christofer Weber
Christofer Weber

Reputation: 1474

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

Upvotes: 1

Related Questions