Merge cells containing the same information in multiple tables with macro

Copper Contributor

Hi everyone, I'm new to this and I'm trying to figure out how to do the following.
I have an excel file, the first sheet is the main table and from this table different subtables are formed and each table is on a different sheet.
For a better visualization of the data, the user needs to see these excel tables with the records grouped together.
All tables have the same columns only their data changes.
As you can see in the first image the table has each record separated in each row but the user wants to view it like the second image in which the table is merged in the records that contain the same information.

antes.PNG

 

despues.PNG

 


I already tried to do this in power automate with an office script connector but I couldn't get it to work and the macro I have is the following, but it only does this merge in the range of cells that I specify and only in a single table.

Sub MergeSameCell()
Set myRange=("DataDesk")
MergeSame:
For Each Cell In myRange
 If cell.Value = cell.Offset(1, 0).Value And Not IsEmpty(cell) Then
 Range(cell, cell.Offset(1, 0)).Merge
 cell.VerticalAlignment = xlCenter
 GoTo MergeSame
 End If
Next cell

End Sub

I would greatly appreciate your help.

3 Replies

Sub MergeSameCell(myRange)
'modify here
'Set myRange=("A5:F17")
MergeSame:
For Each Cell In myRange
 If cell.Value = cell.Offset(1, 0).Value And Not IsEmpty(cell) Then
 Range(cell, cell.Offset(1, 0)).Merge
 cell.VerticalAlignment = xlCenter
 GoTo MergeSame
 End If
Next cell

End Sub
sub main()
' Loop through each worksheet in the workbook
    For Each ws In ThisWorkbook.Worksheets
    set myRange=ws.cells(2,1).currentRange
MergeSame myRange
    Next ws

end sub

 

 

 

 

Sub MergeSameCell(myRange As Range)
    'modify here
    'Set myRange=("A5:F17")

MergeSame:
    For Each cell In myRange
        If cell.Value = cell.Offset(1, 0).Value And Not IsEmpty(cell) Then
            Range(cell, cell.Offset(1, 0)).Merge
            cell.VerticalAlignment = xlCenter
            GoTo MergeSame
        End If
    Next cell
End Sub

Sub main()
    Dim ws As Worksheet
    Dim myRange As Range
    
    ' Loop through each worksheet in the workbook
    For Each ws In ThisWorkbook.Worksheets
        Set myRange = ws.Range("A5:F17") ' Define the range here
        MergeSameCell myRange
    Next ws
End Sub


 

Hi, it works but is there any way to make the window that says: "merging cells only keeps the upper-left value and discards other values" ​​not appear? because you have to click on it several times to perform the action. And if i click on cancel button this message appear: Run time error '1004' Application-defined or object-defined error, and mark the following line in yellow
Range(cell, cell.Offset(1, 0)).Merge

@besthannie25 

Insert the following line above the For ... Next loop:

    Application.DisplayAlerts = False

and below it:

    Application.DisplayAlerts = True