VBA - Deleting duplicate rows and merging cells with unique data - excel

Question

I have would like some help regarding the following problem. Every quarter we a have excel sheets sent to us with client info containing rows often more than a 1000. I've managed to write a code that deletes duplicate rows that are a 100% match, however, a considerable portion still remains due to the following:
A new code I have found kinda works, however I would need some help tweaking it, as it does the following:
It deletes the duplicate and merges the cells, however, if one cell value (in this case Marketing) appears both times it keeps it twice. Also, it does not retain other info like mail/name/phone etc.
Here's the code itself:
Sub Main()
Dim Source As Worksheet: Set Source = ThisWorkbook.Worksheets("Sheet1")
Dim Destination As Worksheet: Set Destination = ThisWorkbook.Worksheets("Sheet2")
Dim Records As Object: Set Records = CreateObject("Scripting.Dictionary")
Dim Data As Variant
Dim Index As Long
Dim Row As Integer: Row = 1
Data = Source.Range("A1", "E" & Source.Rows(Source.UsedRange.Rows.Count).Row).Value2
For Index = LBound(Data, 1) To UBound(Data, 1)
If Records.Exists(Data(Index, 1)) Then
Destination.Cells(Records(Data(Index, 1)), 5).Value2 = Destination.Cells(Records(Data(Index, 1)), 5).Value2 & ", " & Data(Index, 5)
Else
Records.Add Data(Index, 1), Row
Destination.Cells(Row, 1).Value2 = Data(Index, 1)
Destination.Cells(Row, 5).Value2 = Data(Index, 5)
Row = Row + 1
End If
Next Index
Set Records = Nothing
End Sub
I was wondering if there is a way to tackle this problem, or is it too complicated? If the latter, no problems, only deleting the duplicates works fine and reduces work hours a lot.
Thank you for any input and comment!

Answer 1

I use a Dictionary to remove duplicates in a comma delimit string. Email, code and Country are also copied over to the Destination worksheet.
Sub Main()
Dim Source As Worksheet: Set Source = ThisWorkbook.Worksheets("Sheet1")
Dim Destination As Worksheet: Set Destination = ThisWorkbook.Worksheets("Sheet2")
Dim Records As Object: Set Records = CreateObject("Scripting.Dictionary")
Dim Data As Variant
Dim Index As Long
Dim Row As Integer: Row = 1
Data = Source.Range("A1", "E" & Source.Rows(Source.UsedRange.Rows.Count).Row).Value2
With Destination
For Index = LBound(Data, 1) To UBound(Data, 1)
If Records.Exists(Data(Index, 1)) Then
Destination.Cells(Records(Data(Index, 1)), 5).Value2 = removeDuplicates(Destination.Cells(Records(Data(Index, 1)), 5).Value2 & ", " & Data(Index, 5))
Else
Records.Add Data(Index, 1), Row
Destination.Cells(Row, 1).Value2 = Data(Index, 1)
Destination.Cells(Row, 2).Value2 = Data(Index, 2)
Destination.Cells(Row, 3).Value2 = Data(Index, 3)
Destination.Cells(Row, 4).Value2 = Data(Index, 4)
Destination.Cells(Row, 5).Value2 = Data(Index, 5)
Row = Row + 1
End If
Next Index
End With
Set Records = Nothing
End Sub
Function removeDuplicates(values As String)
Dim v As Variant
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
For Each v In Split(values, ",")
If v <> "" Then d(v) = 1
Next
removeDuplicates = Join(d.Keys, ", ")
Set d = Nothing
End Function

Answer 2

Try the following
If Records.Exists(Data(Index, 1)) Then
If InStr(Destination.Cells(Records(Data(Index, 1)), 5).Value2, Data(Index, 5)) = 0 Then
Destination.Cells(Records(Data(Index, 1)), 5).Value2 = Destination.Cells(Records(Data(Index, 1)), 5).Value2 & ", " & Data(Index, 5)
End if
...
InStr searches for a certain String in another, and returns the position at which the string is found. Hence, if Marketing not found, instr will return 0 and it will be added to the cell. If it is already there, Instr will return something largern than 0 and it will not be added again.
Update If you have more records with more than one unit, try this
UnitFull = Data(Index, 5)
Do Until Len(UnitFull) = 0
If InStr(UnitFull, ",") > 0 Then
Unit = Left(UnitFull, Instr(UnitFull, ",") - 1)
UnitFull = Trim(Right(UnitFull, Len(UnitFull) - InStr(UnitFull, ",")))
Else
Unit = UnitFull
UnitFull = ""
End If
Destination.Cells(Records(Data(Index, 1)), 5).Value2 = Destination.Cells(Records(Data(Index, 1)), 5).Value2 & ", " & Unit
Unit = ""
Loop