VBA Code for combine duplicate row and keep columns into same rows

[DoubleT]

Hi, I've a report in Long format and some of the value in column A are duplicate. Is there any VBA code to combine duplicate value but at the same time transform my data into wide format?

This is the report that I've.
Each Employee ID in column A might have duplicate row depends on how many previous company data the employee have.

This is the result I wish to have by using VBA code.

I'm trying to find solution in this forum, unfortunately there are no similar post here.
Appreciate your great help.

Thanks.

 

[Peter_SSs]

I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with.

You may want to tweak the results headers a little but see if this is headed in the right direction

Sub CombineRows()
  Dim lr As Long, r As Long
  
  lr = Range("A" & Rows.Count).End(xlUp).Row
  Application.ScreenUpdating = False
  Range("A2:E" & lr).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo
  For r = lr To 3 Step -1
    If Cells(r, 1).Value = Cells(r - 1, 1).Value Then
      Range("B" & r, Range("A" & r).End(xlToRight)).Copy Destination:=Cells(r - 1, Columns.Count).End(xlToLeft).Offset(, 1)
      Rows(r).Delete
    End If
  Next r
  For r = 6 To Range("A1").CurrentRegion.Columns.Count Step 4
    Cells(1, r).Resize(, 4).Value = Range("B1:E1").Value
  Next r
  Application.ScreenUpdating = True
End Sub

My original sample data

DoubleT.xlsm
	A	B	C	D	E	F
1	Hdr 1	Hdr 2	Hdr 3	Hdr 4	Hdr 5
2	1000	10	21	7	11
3	1000	4	95	58	62
4	2220	61	25	18	30
5	3112	99	32	63	38
6	3112	9	64	17	38
7	5211	53	53	61	74
8	5211	9	78	92	22
9	1000	83	49	68	66
10	3112	38	11	33	53
11
Sheet1 (original)

After the code:

DoubleT.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Hdr 1	Hdr 2	Hdr 3	Hdr 4	Hdr 5	Hdr 2	Hdr 3	Hdr 4	Hdr 5	Hdr 2	Hdr 3	Hdr 4	Hdr 5
2	1000	10	21	7	11	4	95	58	62	83	49	68	66
3	2220	61	25	18	30
4	3112	99	32	63	38	9	64	17	38	38	11	33	53
5	5211	53	53	61	74	9	78	92	22
Sheet1

 

[DoubleT]

I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with.

You may want to tweak the results headers a little but see if this is headed in the right direction

Sub CombineRows()
  Dim lr As Long, r As Long
 
  lr = Range("A" & Rows.Count).End(xlUp).Row
  Application.ScreenUpdating = False
  Range("A2:E" & lr).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo
  For r = lr To 3 Step -1
    If Cells(r, 1).Value = Cells(r - 1, 1).Value Then
      Range("B" & r, Range("A" & r).End(xlToRight)).Copy Destination:=Cells(r - 1, Columns.Count).End(xlToLeft).Offset(, 1)
      Rows(r).Delete
    End If
  Next r
  For r = 6 To Range("A1").CurrentRegion.Columns.Count Step 4
    Cells(1, r).Resize(, 4).Value = Range("B1:E1").Value
  Next r
  Application.ScreenUpdating = True
End Sub

My original sample data

DoubleT.xlsm
	A	B	C	D	E	F
1	Hdr 1	Hdr 2	Hdr 3	Hdr 4	Hdr 5
2	1000	10	21	7	11
3	1000	4	95	58	62
4	2220	61	25	18	30
5	3112	99	32	63	38
6	3112	9	64	17	38
7	5211	53	53	61	74
8	5211	9	78	92	22
9	1000	83	49	68	66
10	3112	38	11	33	53
11
Sheet1 (original)

After the code:

DoubleT.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Hdr 1	Hdr 2	Hdr 3	Hdr 4	Hdr 5	Hdr 2	Hdr 3	Hdr 4	Hdr 5	Hdr 2	Hdr 3	Hdr 4	Hdr 5
2	1000	10	21	7	11	4	95	58	62	83	49	68	66
3	2220	61	25	18	30
4	3112	99	32	63	38	9	64	17	38	38	11	33	53
5	5211	53	53	61	74	9	78	92	22
Sheet1

Hi Peter,

Thank you so much for the coding. It's work well for my task.

By the way, apologize for the inconvenience caused due to the sample raw data.
This is my very first post in mrexcel.

 

[Peter_SSs]

Hi Peter,

Thank you so much for the coding. It's work well for my task.

You're welcome. Thanks for the follow-up.

By the way, apologize for the inconvenience caused due to the sample raw data.
This is my very first post in mrexcel.

No problem. It took us all a while to get to know how the forum works.

 

[OilEconomist]

I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with.

You may want to tweak the results headers a little but see if this is headed in the right direction

Sub CombineRows()
  Dim lr As Long, r As Long
 
  lr = Range("A" & Rows.Count).End(xlUp).Row
  Application.ScreenUpdating = False
  Range("A2:E" & lr).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo
  For r = lr To 3 Step -1
    If Cells(r, 1).Value = Cells(r - 1, 1).Value Then
      Range("B" & r, Range("A" & r).End(xlToRight)).Copy Destination:=Cells(r - 1, Columns.Count).End(xlToLeft).Offset(, 1)
      Rows(r).Delete
    End If
  Next r
  For r = 6 To Range("A1").CurrentRegion.Columns.Count Step 4
    Cells(1, r).Resize(, 4).Value = Range("B1:E1").Value
  Next r
  Application.ScreenUpdating = True
End Sub

My original sample data

DoubleT.xlsm
	A	B	C	D	E	F
1	Hdr 1	Hdr 2	Hdr 3	Hdr 4	Hdr 5
2	1000	10	21	7	11
3	1000	4	95	58	62
4	2220	61	25	18	30
5	3112	99	32	63	38
6	3112	9	64	17	38
7	5211	53	53	61	74
8	5211	9	78	92	22
9	1000	83	49	68	66
10	3112	38	11	33	53
11
Sheet1 (original)

After the code:

DoubleT.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Hdr 1	Hdr 2	Hdr 3	Hdr 4	Hdr 5	Hdr 2	Hdr 3	Hdr 4	Hdr 5	Hdr 2	Hdr 3	Hdr 4	Hdr 5
2	1000	10	21	7	11	4	95	58	62	83	49	68	66
3	2220	61	25	18	30
4	3112	99	32	63	38	9	64	17	38	38	11	33	53
5	5211	53	53	61	74	9	78	92	22
Sheet1

Thanks @Peter_SSs. As I was also able to use this for something similar.

 

[Peter_SSs]

Thanks @Peter_SSs. As I was also able to use this for something similar.

Cheers.