VBA: Merge duplicate rows into one row

[welndmn]

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?
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Mod[/TD]
[TD]1001[/TD]
[TD]1002[/TD]
[TD]1003[/TD]
[TD]1004[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]X[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD][/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]C[/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]D[/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]D[/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]D[/TD]
[TD][/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


The output I am trying to get to.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Mod[/TD]
[TD]1001[/TD]
[TD]1002[/TD]
[TD]1003[/TD]
[TD]1004[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]X[/TD]
[TD]x[/TD]
[TD][/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]X[/TD]
[TD][/TD]
[TD]x[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]C[/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]D[/TD]
[TD]X[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[DanteAmor]

A quick way is to create a pivot table, the result will be like the following image:

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

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

 

[welndmn]

This was perfect, Thanks for saving the day!

 

[DanteAmor]

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

 

[taniko006]

A quick way is to create a pivot table, the result will be like the following image:

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

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.

 

[Flaiban]

I try to use this code and it gives me error. I cant seem to understand why? can you help? Thanks.View attachment 77654

Instead "Sheet1" or "Sheet2" , write name of your sheet .
Ex :
Set sh1 = Sheets("Taniko006")

 

[DanteAmor]

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.

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

 

[Xalithium]

@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.