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

[Hayf13]

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
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1		Forename	Surname	Email	Phone	Em.#	26/07/2021			27/07/2021			28/07/2021
2	Namea@a.comName ASurname A	Name A	Surname A	Namea@a.com	Phone A	A 1				0800	2000	CVA
3	Namea@a.comName ASurname A	Name A	Surname A	Namea@a.com	Phone A	A 1	0800	2000	CVA
4	nameb@b.comName BSurname B	Name B	Surname B	nameb@b.com	Phone B	A 2	0700	1900	CVA
5	nameb@b.comName BSurname B	Name B	Surname B	nameb@b.com	Phone B	A 2				0700	1900	CVA
6	Name C@c.comName CSurname C	Name C	Surname C	Name C@c.com	Phone C	A 3	0800	2000	CVA				0800	2000	CVA
7	Name C@c.comName CSurname C	Name C	Surname C	Name C@c.com	Phone C	A 3				0800	2000	CVA
8	name d@d.comName DSurname D	Name D	Surname D	name d@d.com	Phone D	A 4	1000	1200	CVA
9	name d@d.comName DSurname D	Name D	Surname D	name d@d.com	Phone D	A 4				900	1200	CVA
10	name d@d.comName DSurname D	Name D	Surname D	name d@d.com	Phone D	A 4							1000	1400	cva
11	nameb@b.comName BSurname B	Name B	Surname B	nameb@b.com	Phone B	A 2							0700	1900	CVA
12	Namea@a.comName ASurname A	Name A	Surname A	Namea@a.com	Phone A	A 1							0800	2000	CVA
Sheet1 (2)

Cell Formulas
Range	Formula
A2:A12	A2	=CONCATENATE(D2,B2,C2)

 

[DanteAmor]

Hi and welcome to MrExcel.

Try this:

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

 

[Hayf13]

Try this:

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]

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

 

[Hayf13]

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
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1		Forename	Surname	Email	Phone	Em.#	26/07/2021			27/07/2021			28/07/2021
2	Namea@a.comName ASurname A	Name A	Surname A	Namea@a.com	Phone A	A 1				0800	2000	CVA
3	Namea@a.comName ASurname A	Name A	Surname A	Namea@a.com	Phone A	A 1	0800	2000	CVA
4	nameb@b.comName BSurname B	Name B	Surname B	nameb@b.com	Phone B	A 2	0700	1900	CVA
5	nameb@b.comName BSurname B	Name B	Surname B	nameb@b.com	Phone B	A 2				0700	1900	CVA
6	Name C@c.comName CSurname C	Name C	Surname C	Name C@c.com	Phone C	A 3	0800	2000	CVA				0800	2000	CVA
7	Name C@c.comName CSurname C	Name C	Surname C	Name C@c.com	Phone C	A 3				0800	2000	CVA
8	name d@d.comName DSurname D	Name D	Surname D	name d@d.com	Phone D	A 4	1000	1200	CVA
9	name d@d.comName DSurname D	Name D	Surname D	name d@d.com	Phone D	A 4				900	1200	CVA
10	name d@d.comName DSurname D	Name D	Surname D	name d@d.com	Phone D	A 4							1000	1400	cva
11	nameb@b.comName BSurname B	Name B	Surname B	nameb@b.com	Phone B	A 2							0700	1900	CVA
12	Namea@a.comName ASurname A	Name A	Surname A	Namea@a.com	Phone A	A 1							0800	2000	CVA
13	namee@e.comName ESurname E	Name E	Surname E	namee@e.com
14	Name F@f.comName FSurname F	Name F	Surname F	Name F@f.com
15
16
17
18
19
Sheet 1

Cell Formulas
Range	Formula
A2:A19	A2	=CONCATENATE(D2,B2,C2)

Sheet 2 Success:

basic test.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
2	Namea@a.comName ASurname A	Name A	Surname A	Namea@a.com	Phone A	A 1	800	2000	CVA	800	2000	CVA	800	2000	CVA
3	nameb@b.comName BSurname B	Name B	Surname B	nameb@b.com	Phone B	A 2	700	1900	CVA	700	1900	CVA	700	1900	CVA
4	Name C@c.comName CSurname C	Name C	Surname C	Name C@c.com	Phone C	A 3	800	2000	CVA	800	2000	CVA	800	2000	CVA
5	name d@d.comName DSurname D	Name D	Surname D	name d@d.com	Phone D	A 4	1000	1200	CVA	900	1200	CVA	1000	1400	cva
6
Sheet 2

Sheet 2 after adding data to sheet 1

basic test.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
2	Namea@a.comName ASurname A	Name A	Surname A	Namea@a.com	Phone A	A 1	800	2000	CVA	800	2000	CVA	800	2000	CVA
3	namee@e.comName ESurname E	Name E	Surname E	namee@e.com	Phone B	A 2	700	1900	CVA	700	1900	CVA	700	1900	CVA
4	Name F@f.comName FSurname F	Name F	Surname F	Name F@f.com	Phone C	A 3	800	2000	CVA	800	2000	CVA	800	2000	CVA
5	name d@d.comName DSurname D	Name D	Surname D	name d@d.com	Phone D	A 4	1000	1200	CVA	900	1200	CVA	1000	1400	cva
6
Sheet 2

 

[DanteAmor]

I already saw what my fault is, I assumed that the data in column A was sorted.
Change this line:

j = j + 1

For this:

j = dic.Count + 1

 

[Hayf13]

I already saw what my fault is, I assumed that the data in column A was sorted.
Change this line:

j = j + 1

For this:

j = dic.Count + 1

That's Just the ticket! Really appreciate the swift help on this, this forum is fantastic!!

Take care!