VBA - Merge Cells with Dynamic Range

[VRD]

Hello everyone, I am having trouble to write a Macro that is supposed to Merge the cells with the same Value and later format them with a thick boarder.

The problem that I have are two:
1) I do not know how many cells I need to merge each time I run the Macro
2) A Machine number that today appears on my list might not be on the list tomorrow

Here is a small example of the current situation: and here is what its supposed to look like

I have already thought about creating a hidden column in the middle to count how many times this Machine appears, and with this information use a Macro that merge based on the cell value.
But maybe there is a better way to do so.

Thanks

 

[Joe4]

Welcome to the Board!

In General, we usually recommend that people NOT merge cells.
Merged cells cause a whole host of issues for Excel, with things like sorting, VBA, look-up formulas, etc.
So if you need to do other things with this data, merging cells could end up making your data much more difficult to work with.

However, if this is just for presentation purposes, that might not be a concern. Here is VBA code that should do what you want:

Sub MyMergeCells()

    Dim r As Long
    Dim lr As Long
    Dim sr As Long
    Dim ct As Long
        
    Application.ScreenUpdating = False
        
'   Find last cell in column A with data
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Initialize value
    sr = 2
    ct = 1
    
'   Loop through all rows in column A, starting with row 3
    For r = 3 To lr + 1
'       Check to see if value is same as row above
        If Cells(r - 1, "A").Value = Cells(r, "A").Value Then
'           increment counter
            ct = ct + 1
        Else
'           Check to see if counter is greater than 1
            If ct > 1 Then
'               Merge cells above
                Application.DisplayAlerts = False
                With Range(Cells(sr, "A"), Cells(r - 1, "A"))
                    .Merge
                    '.HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                End With
                Application.DisplayAlerts = True
'               Reset counter and starting row
                ct = 1
                sr = r
            Else
'               Reset starting row
                sr = r
            End If
        End If
    Next
            
    Application.ScreenUpdating = True
    
End Sub

 

[VRD]

Welcome to the Board!

In General, we usually recommend that people NOT merge cells.
Merged cells cause a whole host of issues for Excel, with things like sorting, VBA, look-up formulas, etc.
So if you need to do other things with this data, merging cells could end up making your data much more difficult to work with.

However, if this is just for presentation purposes, that might not be a concern. Here is VBA code that should do what you want:

Sub MyMergeCells()

    Dim r As Long
    Dim lr As Long
    Dim sr As Long
    Dim ct As Long
       
    Application.ScreenUpdating = False
       
'   Find last cell in column A with data
    lr = Cells(Rows.Count, "A").End(xlUp).Row
   
'   Initialize value
    sr = 2
    ct = 1
   
'   Loop through all rows in column A, starting with row 3
    For r = 3 To lr + 1
'       Check to see if value is same as row above
        If Cells(r - 1, "A").Value = Cells(r, "A").Value Then
'           increment counter
            ct = ct + 1
        Else
'           Check to see if counter is greater than 1
            If ct > 1 Then
'               Merge cells above
                Application.DisplayAlerts = False
                With Range(Cells(sr, "A"), Cells(r - 1, "A"))
                    .Merge
                    '.HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                End With
                Application.DisplayAlerts = True
'               Reset counter and starting row
                ct = 1
                sr = r
            Else
'               Reset starting row
                sr = r
            End If
        End If
    Next
           
    Application.ScreenUpdating = True
   
End Sub

Thank you very much,

I was about to post here on the forum one solution that I have found but had to run several times to achieve the desired result,

This is what I have initially thought. But your solution was way better than mine. Once again thank you for your time

Sub Merge_cells()

Dim cell As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each cell In Range("A1:A1000")
If cell.Value = cell.Offset(1, 0).Value Then
Range(cell, cell.Offset(1, 0)).Merge
cell.HorizontalAlignment = xlCenter
cell.VerticalAlignment = xlCenter
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

 

[Joe4]

You are welcome.