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]

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

View attachment 79301

I tested the code with 1000+ records and it works.
You must have a problem with your data. Check that you have your data correct in your sheet, without errors in cells such as #N/A, #VALUE, etc.
Or share your file to review it.

You could upload a copy of your file to a free site such www.dropbox.com or google drive. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[BBCC0000]

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

Hi, thanks for your reply.

The code results this, which the gender column has deleted and made the right 2 columns repeated.

Any solutions for this?

 

[BBCC0000]

Let me clarify again.

This is the original one.

And this is the result I wanted.

It merged first column if the ID and name are same. The code will replace the A2 cell. After merging, the extra rows will be deleted.

Thank you in advance and sorry for the inconvenience caused.

 

[DanteAmor]

Let me clarify again.

This is the original one.

View attachment 79390

And this is the result I wanted.

View attachment 79391

It merged first column if the ID and name are same. The code will replace the A2 cell. After merging, the extra rows will be deleted.

Thank you in advance and sorry for the inconvenience caused.

With that sample, the macro works.
If you are testing with other data, some of that data may have a problem, if you share your file it could help you.

 

[BBCC0000]

With that sample, the macro works.
If you are testing with other data, some of that data may have a problem, if you share your file it could help you.

test.xlsx

Sheet1 date_1,id,name,code,date_2 8/24/2018,3591172374,Darcy,64,11/12/2018 5/8/2018,8818525879,Carina,84,11/14/2018 4/23/2018,9586906492,Max,12 9/4/2018,4531537043,Miley,43,11/16/2018 5/16/2018,6620228120,Freddie,16,11/12/2018 8/30/2018,4159562346,Ned,29,11/15/2018 6/28/2018,7939422643,Catherine,18

docs.google.com

Sorry for the late as I am creating these data. You may download the file for your kind perusal and try executing the code.

For my side, it shows error 400.

Let me know the result from your side. Thank you.

 

[bebo021999]

Try:

Option Explicit
Sub Merge_Duplicated()
Dim lr&, i&, k&, rng, st As String, s1 As String, s2 As String, s
Dim dic As Object, key, res()
Set dic = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, "B").End(xlUp).Row
rng = Range("A2:E" & lr).Value
For i = 1 To UBound(rng)
    st = rng(i, 1) & "|" & rng(i, 3) & "|" & rng(i, 4) & "|" & rng(i, 5)
    If Not dic.exists(rng(i, 2)) Then
        dic.Add rng(i, 2), st
    Else
        s = Split(dic(rng(i, 2)), "|")
        If Not rng(i, 1) Like s(0) Then
            s1 = IIf(s(0) = "", rng(i, 1), s(0) & " & " & rng(i, 1))
        Else: s1 = rng(i, 1)
        End If
        If Not rng(i, 5) Like s(3) Then
            s2 = IIf(s(3) = "", rng(i, 5), s(3) & " & " & rng(i, 5))
        Else: s2 = rng(i, 5)
        End If
        dic(rng(i, 2)) = s1 & "|" & rng(i, 3) & "|" & rng(i, 4) & "|" & s2
    End If
Next
ReDim res(1 To dic.Count, 1 To 5)
For Each key In dic.keys
    k = k + 1: s = Split(dic(key), "|")
    res(k, 1) = s(0): res(k, 2) = key: res(k, 3) = s(1): res(k, 4) = s(2): res(k, 5) = s(3)
Next
Range("H2:L100000").ClearContents
Range("H2").Resize(dic.Count, 5).Value = res
End Sub

TEST.xlsm

drive.google.com

 

[BBCC0000]

Try:

Option Explicit
Sub Merge_Duplicated()
Dim lr&, i&, k&, rng, st As String, s1 As String, s2 As String, s
Dim dic As Object, key, res()
Set dic = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, "B").End(xlUp).Row
rng = Range("A2:E" & lr).Value
For i = 1 To UBound(rng)
    st = rng(i, 1) & "|" & rng(i, 3) & "|" & rng(i, 4) & "|" & rng(i, 5)
    If Not dic.exists(rng(i, 2)) Then
        dic.Add rng(i, 2), st
    Else
        s = Split(dic(rng(i, 2)), "|")
        If Not rng(i, 1) Like s(0) Then
            s1 = IIf(s(0) = "", rng(i, 1), s(0) & " & " & rng(i, 1))
        Else: s1 = rng(i, 1)
        End If
        If Not rng(i, 5) Like s(3) Then
            s2 = IIf(s(3) = "", rng(i, 5), s(3) & " & " & rng(i, 5))
        Else: s2 = rng(i, 5)
        End If
        dic(rng(i, 2)) = s1 & "|" & rng(i, 3) & "|" & rng(i, 4) & "|" & s2
    End If
Next
ReDim res(1 To dic.Count, 1 To 5)
For Each key In dic.keys
    k = k + 1: s = Split(dic(key), "|")
    res(k, 1) = s(0): res(k, 2) = key: res(k, 3) = s(1): res(k, 4) = s(2): res(k, 5) = s(3)
Next
Range("H2:L100000").ClearContents
Range("H2").Resize(dic.Count, 5).Value = res
End Sub

TEST.xlsm

drive.google.com

It works well. Thanks very much!

 

[DanteAmor]

test.xlsx

Sheet1 date_1,id,name,code,date_2 8/24/2018,3591172374,Darcy,64,11/12/2018 5/8/2018,8818525879,Carina,84,11/14/2018 4/23/2018,9586906492,Max,12 9/4/2018,4531537043,Miley,43,11/16/2018 5/16/2018,6620228120,Freddie,16,11/12/2018 8/30/2018,4159562346,Ned,29,11/15/2018 6/28/2018,7939422643,Catherine,18

docs.google.com

Sorry for the late as I am creating these data. You may download the file for your kind perusal and try executing the code.

For my side, it shows error 400.

Let me know the result from your side. Thank you.

Here is the updated code:

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).Row).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