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

DoubleT

New Member
Joined
Jan 8, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
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.

1610094195295.png


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

1610094508105.png


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

Thanks.
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
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

VBA Code:
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
ABCDEF
1Hdr 1Hdr 2Hdr 3Hdr 4Hdr 5
210001021711
310004955862
4222061251830
5311299326338
631129641738
7521153536174
852119789222
9100083496866
10311238113353
11
Sheet1 (original)



After the code:

DoubleT.xlsm
ABCDEFGHIJKLM
1Hdr 1Hdr 2Hdr 3Hdr 4Hdr 5Hdr 2Hdr 3Hdr 4Hdr 5Hdr 2Hdr 3Hdr 4Hdr 5
210001021711495586283496866
3222061251830
4311299326338964173838113353
55211535361749789222
Sheet1
 
Upvote 0
Solution
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

VBA Code:
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
ABCDEF
1Hdr 1Hdr 2Hdr 3Hdr 4Hdr 5
210001021711
310004955862
4222061251830
5311299326338
631129641738
7521153536174
852119789222
9100083496866
10311238113353
11
Sheet1 (original)



After the code:

DoubleT.xlsm
ABCDEFGHIJKLM
1Hdr 1Hdr 2Hdr 3Hdr 4Hdr 5Hdr 2Hdr 3Hdr 4Hdr 5Hdr 2Hdr 3Hdr 4Hdr 5
210001021711495586283496866
3222061251830
4311299326338964173838113353
55211535361749789222
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. :)
 
Upvote 0
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. :biggrin:
 
Upvote 0
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

VBA Code:
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
ABCDEF
1Hdr 1Hdr 2Hdr 3Hdr 4Hdr 5
210001021711
310004955862
4222061251830
5311299326338
631129641738
7521153536174
852119789222
9100083496866
10311238113353
11
Sheet1 (original)



After the code:

DoubleT.xlsm
ABCDEFGHIJKLM
1Hdr 1Hdr 2Hdr 3Hdr 4Hdr 5Hdr 2Hdr 3Hdr 4Hdr 5Hdr 2Hdr 3Hdr 4Hdr 5
210001021711495586283496866
3222061251830
4311299326338964173838113353
55211535361749789222
Sheet1
Thanks @Peter_SSs. As I was also able to use this for something similar.
 
Upvote 0

Forum statistics

Threads
1,213,562
Messages
6,114,322
Members
448,564
Latest member
ED38

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
Back
Top