Merging data from many rows that have duplicate values in column A VBA - Desperate for help

Hayf13

New Member
Joined
Jul 27, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hi Team, I'm a complete newby to Forums - have tried searching for what i'm after to no avail, hope I'm not breaching any protocol with the below; desperately trying to work out the following, but keep running into a brick wall.

To give the background Jist, I have a few sheets of data from various pieces of work I'm now pulling through into one central sheet through a Macro which works fine, which gives me one long list of data through Columns A:AD on Sheet 1 What i'm after and completely lost with is how to go about merging this data to search value in column A of which there will be likely to be multiple of the same value (In this case is an email address) - and then combine all the values from Columns A:AD into one row, leaving only one row with that email address and data into Sheet 2 - have attached a basic sheet of what i'm working with and a visual below of what I'm hoping to achieve - had found the following VBA which seems to condense the sheet - but not properly merge the data (For this purpose will only require text/values in the final output) - (Need this to be done VIA VBA as opposed to a pivot table) hoping this makes sense!

Any help from anyone would be huge, Thanks to all! Take care!

Sheet 1
A B C D E F etc --> AD
a@a.com X X
b@a.com X X X
c@a.com X
a@a.com X X
d@a.com X
c@a.com X X

Required Output on Sheet 2

A B C D E F etc --> AD
a@a.com X X X X
b@a.com X X X
c@a.com X X X
d@a.com X


Macro Found That Almost Seems to work -

Sub mergeduplicaterows()

Dim sh1 As Worksheet, sh2 As Worksheet, i As Long, j As Long, f As Range, g As Range
Application.ScreenUpdating = False
Set sh1 = Sheets("Sheet 1")
Set sh2 = Sheets("Sheet 2")
sh2.Cells.ClearContents
sh1.Rows(1).Copy sh2.Rows(1)
For i = 2 To sh1.Range("A" & Rows.Count).End(xlUp).Row
For j = 2 To sh1.Cells(i, Columns.Count).End(xlToLeft).Column
If sh1.Cells(i, j) <> "" Then
Set f = sh2.Range("A:AD").Find(sh1.Cells(i, "A"), , xlValues, xlWhole)
If Not f Is Nothing Then
Set g = sh2.Rows(1).Find(sh1.Cells(1, j), , xlValues, xlWhole)
If Not g Is Nothing Then
sh2.Cells(f.Row, g.Column) = sh1.Cells(i, j)
End If
Else
sh1.Rows(i).Copy sh2.Range("A" & sh2.Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
End If
Next
Next
End Sub


basic test.xlsm
ABCDEFGHIJKLMNO
1ForenameSurnameEmailPhoneEm.#26/07/202127/07/202128/07/2021
2Namea@a.comName ASurname AName ASurname ANamea@a.comPhone AA 108002000CVA
3Namea@a.comName ASurname AName ASurname ANamea@a.comPhone AA 108002000CVA
4nameb@b.comName BSurname BName BSurname Bnameb@b.comPhone BA 207001900CVA
5nameb@b.comName BSurname BName BSurname Bnameb@b.comPhone BA 207001900CVA
6Name C@c.comName CSurname CName CSurname CName C@c.comPhone CA 308002000CVA08002000CVA
7Name C@c.comName CSurname CName CSurname CName C@c.comPhone CA 308002000CVA
8name d@d.comName DSurname DName DSurname Dname d@d.comPhone DA 410001200CVA
9name d@d.comName DSurname DName DSurname Dname d@d.comPhone DA 49001200CVA
10name d@d.comName DSurname DName DSurname Dname d@d.comPhone DA 410001400cva
11nameb@b.comName BSurname BName BSurname Bnameb@b.comPhone BA 207001900CVA
12Namea@a.comName ASurname AName ASurname ANamea@a.comPhone AA 108002000CVA
Sheet1 (2)
Cell Formulas
RangeFormula
A2:A12A2=CONCATENATE(D2,B2,C2)
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,922
Office Version
  1. 2007
Platform
  1. Windows
Hi and welcome to MrExcel.

Try this:

VBA Code:
Sub Merge_Duplicate_Rows()
  Dim sh1 As Worksheet
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
 
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh1 = Sheets("Sheet 1")
  a = sh1.Range("A2", sh1.Cells(sh1.Range("A" & Rows.Count).End(3).Row, _
      sh1.UsedRange.Columns(sh1.UsedRange.Columns.Count).Column))
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
 
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      j = j + 1
      dic(a(i, 1)) = j
    Else
      j = dic(a(i, 1))
    End If
    For k = 1 To UBound(a, 2)
      If a(i, k) <> "" Then b(j, k) = a(i, k)
    Next
  Next
  Sheets("Sheet 2").Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
 
Last edited:
Solution

Hayf13

New Member
Joined
Jul 27, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Try this:

VBA Code:
Sub Merge_Duplicate_Rows()
  Dim sh1 As Worksheet
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
 
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh1 = Sheets("Sheet 1")
  a = sh1.Range("A2", sh1.Cells(sh1.Range("A" & Rows.Count).End(3).Row, _
      sh1.UsedRange.Columns(sh1.UsedRange.Columns.Count).Column))
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
 
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      j = j + 1
      dic(a(i, 1)) = j
    Else
      j = dic(a(i, 1))
    End If
    For k = 1 To UBound(a, 2)
      If a(i, k) <> "" Then b(j, k) = a(i, k)
    Next
  Next
  Sheets("Sheet 2").Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
Dante you hero, This seems to work perfectly!

Hugely Appreciated, take care!
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,922
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

Hayf13

New Member
Joined
Jul 27, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

I'm glad to help you. Thanks for the feedback.
Thankyou :D

Although, wondered if I could pick your brains just for a quick moment longer, just expanded the search and added a few extra lines to test - it seems to work on the initial 4 values, however if I extend the data set removes data "b" instead of adding a new line for those, wondered if I was missing something obvious to change? Have attached below - Appreciate the response!!

basic test.xlsm
ABCDEFGHIJKLMNO
1ForenameSurnameEmailPhoneEm.#26/07/202127/07/202128/07/2021
2Namea@a.comName ASurname AName ASurname ANamea@a.comPhone AA 108002000CVA
3Namea@a.comName ASurname AName ASurname ANamea@a.comPhone AA 108002000CVA
4nameb@b.comName BSurname BName BSurname Bnameb@b.comPhone BA 207001900CVA
5nameb@b.comName BSurname BName BSurname Bnameb@b.comPhone BA 207001900CVA
6Name C@c.comName CSurname CName CSurname CName C@c.comPhone CA 308002000CVA08002000CVA
7Name C@c.comName CSurname CName CSurname CName C@c.comPhone CA 308002000CVA
8name d@d.comName DSurname DName DSurname Dname d@d.comPhone DA 410001200CVA
9name d@d.comName DSurname DName DSurname Dname d@d.comPhone DA 49001200CVA
10name d@d.comName DSurname DName DSurname Dname d@d.comPhone DA 410001400cva
11nameb@b.comName BSurname BName BSurname Bnameb@b.comPhone BA 207001900CVA
12Namea@a.comName ASurname AName ASurname ANamea@a.comPhone AA 108002000CVA
13namee@e.comName ESurname EName ESurname Enamee@e.com
14Name F@f.comName FSurname FName FSurname FName F@f.com
15 
16 
17 
18 
19 
Sheet 1
Cell Formulas
RangeFormula
A2:A19A2=CONCATENATE(D2,B2,C2)


Sheet 2 Success:

basic test.xlsm
ABCDEFGHIJKLMNO
2Namea@a.comName ASurname AName ASurname ANamea@a.comPhone AA 18002000CVA8002000CVA8002000CVA
3nameb@b.comName BSurname BName BSurname Bnameb@b.comPhone BA 27001900CVA7001900CVA7001900CVA
4Name C@c.comName CSurname CName CSurname CName C@c.comPhone CA 38002000CVA8002000CVA8002000CVA
5name d@d.comName DSurname DName DSurname Dname d@d.comPhone DA 410001200CVA9001200CVA10001400cva
6
Sheet 2


Sheet 2 after adding data to sheet 1

basic test.xlsm
ABCDEFGHIJKLMNO
2Namea@a.comName ASurname AName ASurname ANamea@a.comPhone AA 18002000CVA8002000CVA8002000CVA
3namee@e.comName ESurname EName ESurname Enamee@e.comPhone BA 27001900CVA7001900CVA7001900CVA
4Name F@f.comName FSurname FName FSurname FName F@f.comPhone CA 38002000CVA8002000CVA8002000CVA
5name d@d.comName DSurname DName DSurname Dname d@d.comPhone DA 410001200CVA9001200CVA10001400cva
6
Sheet 2
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,922
Office Version
  1. 2007
Platform
  1. Windows
I already saw what my fault is, I assumed that the data in column A was sorted.
Change this line:
VBA Code:
j = j + 1

For this:
VBA Code:
j = dic.Count + 1
 

Hayf13

New Member
Joined
Jul 27, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
I already saw what my fault is, I assumed that the data in column A was sorted.
Change this line:
VBA Code:
j = j + 1

For this:
VBA Code:
j = dic.Count + 1
That's Just the ticket! Really appreciate the swift help on this, this forum is fantastic!!

Take care!
 

Forum statistics

Threads
1,147,732
Messages
5,742,854
Members
423,759
Latest member
meb229

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top