Merging duplicate values

[kralin]

Hello - any assistance with this would be greatly appreciated.

I have the following output in Excel:

ID Contact with Date Length of contact
1 John Smith 01/01/2024 60
1 Joan Smith 01/01/2024 60
1 John Smith 02/01/2024 45

and so on for many IDs and numerous contacts - about 5000 rows of data

My desired output however would be

ID Contact with Date Length of contact
1 John Smith and Joan Smith 01/01/2024 60
1 John Smith 02/01/2024 45



Eg I would like to merge the Contact With value when there is a duplicate value for ID, Date and Length of Contact. I would then like to delete the duplicate row so I am left with distinct contacts.



Any assistance with this would be massively appreciated.


Many thanks

 

[DanteAmor]

If your data starts in cell A1 like the following example:

Dante Amor
	A	B	C	D
1	ID	Contact	Date	Length
2	1	John Smith	01/01/2024	60
3	1	Joan Smith	01/01/2024	60
4	1	John Smith	02/01/2024	45
S1

Try this macro:

Sub MergingDuplicateValues()
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim ky As String
  Dim i As Long, k As Long
 
  a = Range("A2", Range("D" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a, 1)
    ky = a(i, 1) & "|" & a(i, 3) & "|" & a(i, 4)
    If Not dic.exists(ky) Then
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = a(i, 2)
      b(k, 3) = a(i, 3)
      b(k, 4) = a(i, 4)
      dic(ky) = k
    Else
      k = dic(ky)
      b(k, 2) = b(k, 2) & ", " & a(i, 2)
    End If
  Next
 
  Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Result:

Dante Amor
	A	B	C	D
1	ID	Contact	Date	Length
2	1	John Smith, Joan Smith	01/01/2024	60
3	1	John Smith	02/01/2024	45
4
S1