Merge duplicated rows

[BBCC0000]

Hi all,

Does anyone know how to merge duplicated rows by using Excel VBA?

For example, this file has two same ID and Name but the dates are different. I want their dates to be merged, while the ID and Name remain the same. Then delete the other whole duplicated row.

The final result would be:

Appreciate and thanks to anyone who can help me to create this Excel VBA.

 

[DanteAmor]

The macro assumes that your data starts in cell A2.

In the last row of the macro:
The result puts it in cell E2 onwards, if you want it in the same cells then change E2 to A2.


Try this:

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

  Range("E2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

 

[BBCC0000]

Thank you very much. The code works on me.

Let's say if I have added more columns, which part of code should I change?

Thanks in advance.

The macro assumes that your data starts in cell A2.

In the last row of the macro:
The result puts it in cell E2 onwards, if you want it in the same cells then change E2 to A2.


Try this:

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

  Range("E2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

 

[BBCC0000]

Hi @DanteAmor, could you please help me on this? I have tried modifying the code but it wouldn't work. Thanks.

 

[DanteAmor]

Now you must include the birthday, what would be the result?

 

[BBCC0000]

The result would be like this.

 

[BBCC0000]

Hi,

You have any idea on this?

Now you must include the birthday, what would be the result?

 

[DanteAmor]

Try:

Sub Merge_Duplicated()
  Dim a As Variant, b As Variant
  Dim dic As Object
  Dim ky As String
  Dim i As Long, j As Long, k As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  a = Range("A2:G" & Range("B" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
  
  For i = 1 To UBound(a, 1)
    ky = a(i, 2) & "|" & a(i, 3)
    If Not dic.exists(ky) Then
      dic(ky) = dic.Count + 1
    End If
    j = dic(ky)
    b(j, 1) = IIf(b(j, 1) = "", a(i, 1), b(j, 1) & " & " & a(i, 1))
    For k = 2 To 7
      b(j, k) = a(i, k)
    Next
  Next
  Range("I2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

 

[BBCC0000]

Try:

Sub Merge_Duplicated()
  Dim a As Variant, b As Variant
  Dim dic As Object
  Dim ky As String
  Dim i As Long, j As Long, k As Long
 
  Set dic = CreateObject("Scripting.Dictionary")
  a = Range("A2:G" & Range("B" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
 
  For i = 1 To UBound(a, 1)
    ky = a(i, 2) & "|" & a(i, 3)
    If Not dic.exists(ky) Then
      dic(ky) = dic.Count + 1
    End If
    j = dic(ky)
    b(j, 1) = IIf(b(j, 1) = "", a(i, 1), b(j, 1) & " & " & a(i, 1))
    For k = 2 To 7
      b(j, k) = a(i, k)
    Next
  Next
  Range("I2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Thanks. It has the error 400 when I applied this code to 100+ rows. How do I fix this?

 

[mohadin]

Hi
Try

Sub test()
  Dim a, w
  Dim tx As String
  Dim i&
   a = Range("A2:G" & Cells(Rows.Count, 1).End(xlUp).Row).Value
  With CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a, 1)
    tx = a(i, 2) & a(i, 3)
    If Not .exists(tx) Then
      .Add tx, Array(a(i, 1), a(i, 2), a(i, 3), a(i, 5), a(i, 6), a(i, 7))
      Else
      w = .Item(tx): w(0) = w(0) & " & " & a(i, 1): .Item(tx) = w
    End If
  Next
  Range("I2").Resize(.Count, UBound(a, 2) - 1) = Application.Index(.items, 0, 0)
  End With
End Sub