How to delete duplicates in excel in different situations (VBA)? - excel

Question

I need to sum corresponding values in to the right columns, but also delete duplicates. Here's the deal:
If, for example, I have columns from A to F. If columns A to E are the same with another row, macro deletes the row and saves older one.
IF columns A to C are same with another existing row, macro deletes another row and adds those corresponding values from column D and E to the remaining row. Here is an example:
cell1 cell2 cell3 cell4 cell5 cell6
1 1 1 1 1 1
2 2 2 2 2 2
2 2 2 2 2 2
1 1 1 2 2 1
3 3 3 3 3 3
After macro:
cell1 cell2 cell3 cell4 cell5 cell6
1 1 1 3 3 1
2 2 2 2 2 2
3 3 3 3 3 3
So now, macro has deleted row 4 (because it has same values on column A to C as row 1 has) an adds corresponding values from columns D and E to row 1. Also, rows 2 and 3 are duplicates from column A to E, so macro deletes row 3.
Here is an example what I have tried (I got help before with sum-problem (from #JvdV) and adding corresponding values in to right ones works, but I don't know, how to remove duplicates correctly..)
Class module:
Public Col1 As Variant
Public Col2 As Variant
Public Col3 As Variant
Public Col4 As Variant
Public Col5 As Variant
Public Col6 As Variant
Module:
Dim x As Long, arr As Variant, lst As Class1
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
With Sheet1
x = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A1:F" & x).Value
End With
.Range("A1:F" & x).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlYes
For x = LBound(arr) To UBound(arr)
If Not dict.Exists(arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3)) Then
Set lst = New Class1
lst.Col1 = arr(x, 1)
lst.Col2 = arr(x, 2)
lst.Col3 = arr(x, 3)
lst.Col4 = arr(x, 4)
lst.Col5 = arr(x, 5)
lst.Col6 = arr(x, 6)
dict.Add arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3), lst
Else
dict(arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3)).Col4 = dict(arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3)).Col4 + arr(x, 4)
dict(arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3)).Col5 = dict(arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3)).Col5 + arr(x, 5)
End If
Next x
With Sheet1
x = 1
For Each Key In dict.Keys
.Cells(x, 1).Value = dict(Key).Col1
.Cells(x, 2).Value = dict(Key).Col2
.Cells(x, 3).Value = dict(Key).Col3
.Cells(x, 4).Value = dict(Key).Col4
.Cells(x, 5).Value = dict(Key).Col5
.Cells(x, 6).Value = dict(Key).Col6
x = x + 1
Next Key
End With
End Sub

Answer 1

Some mistakes in your code, including populating your array before deleting first duplicates and having your RemoveDuplicates outside your With statement and including column F. To make your code work properly you could try the below:
Before
Sub Test()
Dim x As Long, arr As Variant, lst As Class1
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
With Sheet1
'Step one: Delete duplicates over columns A-E
x = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A1:F" & x).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes
'Step two: Populate your array
x = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A2:F" & x).Value
'Step three: Clear range
.Range("A2:F" & x).ClearContents
'Step Four: Go through your array and populate a dictionary
For x = LBound(arr) To UBound(arr)
Set lst = New Class1
lst.Col1 = arr(x, 1)
lst.Col2 = arr(x, 2)
lst.Col3 = arr(x, 3)
lst.Col4 = arr(x, 4)
lst.Col5 = arr(x, 5)
lst.Col6 = arr(x, 6)
KeyX = Join(Array(arr(x, 1), arr(x, 2), arr(x, 3)), "|")
If dict.Exists(KeyX) = False Then
dict.Add KeyX, lst
Else
dict(KeyX).Col4 = dict(KeyX).Col4 + arr(x, 4)
dict(KeyX).Col5 = dict(KeyX).Col5 + arr(x, 5)
End If
Next x
'Step five: Go through your dictionary and write to sheet
x = 2
For Each key In dict.Keys
.Range(.Cells(x, 1), .Cells(x, 6)).Value = Array(dict(key).Col1, dict(key).Col2, dict(key).Col3, dict(key).Col4, dict(key).Col5, dict(key).Col6)
x = x + 1
Next key
End With
End Sub
After
Let me know how it went =)