VBA: Merge duplicate rows into one row

welndmn

New Member
Joined
Oct 22, 2013
Messages
31
Maybe my search words are lacking what they need for me to find the answer, so I need help.
I have a table like this, where you can see Mod "a" was duplicated on 2 rows.
I was trying to write the code to where if it was matching in column A, pasteall skip blanks, but It's not working for me.
Any help or advise?
Mod1001100210031004
AX
AX
AX
BX
BX
CX
DX
DX
DX

<tbody>
</tbody>


The output I am trying to get to.

Mod1001100210031004
AXxx
BXx
CX
DXxx

<tbody>
</tbody>
 
Last edited:

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
A quick way is to create a pivot table, the result will be like the following image:

afbbf3765d78a797c3d85e3dfffdc837.jpg


--------------------
The other way is with the following macro. The result will remain on sheet2

Code:
Sub Merge_Duplicate()
  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("[COLOR=#0000ff]Sheet1[/COLOR]")
  Set sh2 = Sheets("[COLOR=#0000ff]Sheet2[/COLOR]")
  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:A").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
 
Upvote 0
I'm glad to help you. Thanks for the feedback.
 
Upvote 0
A quick way is to create a pivot table, the result will be like the following image:

afbbf3765d78a797c3d85e3dfffdc837.jpg


--------------------
The other way is with the following macro. The result will remain on sheet2

Code:
Sub Merge_Duplicate()
  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("[COLOR=#0000ff]Sheet1[/COLOR]")
  Set sh2 = Sheets("[COLOR=#0000ff]Sheet2[/COLOR]")
  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:A").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
I try to use this code and it gives me error. I cant seem to understand why? can you help? Thanks.
1667409824764.png
 
Upvote 0
Hi and welcome to MrExcel!

Change in the macro "Sheet1" to the name of your sheet that contains the data. Change "Sheet2" in the macro to the name of the sheet that will have the results.

VBA Code:
Sub Merge_Duplicate()
  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("Sheet1")
  Set sh2 = Sheets("Sheet2")
  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:A").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
 
Upvote 0
@DanteAmor

Your macro works as a charm. Can it be done that it merges both rows and columns at the same time?
I tried chatgpt to no avail. It fails to understand what this macro does.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

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