How to merge similar cells in excel with VBA

Question

I am new in VBA but I am trying my best to combine cells with a macro.
The exact thing I need is quite complicated: combine cells in a row if they have the same string (and a plus is to put a border in the merged cell)

See graphic example here:

example how to merge cells

I have tried with this code but it doesn't work well, specially when merging one cell with a previous one that has been merged already.

Could you give me some help?

Thanks in advance!

Sub Main()

    Dim i As Long
    Dim j As Long

    For i = 1 To 5
        For j = 1 To 15
            If StrComp(Cells(i, j), Cells(i, j + 1), vbTextCompare) = 0 Then
                Range(Cells(i, j), Cells(i, j + 1)).Merge
                SendKeys "~"
            End If
        Next j
    Next i

End Sub

Answer 1

Or you may try something like this...

Sub MergeSimilarCells()
Dim lr As Long, lc As Long, i As Long, j As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
Application.DisplayAlerts = False
For i = 1 To lr
    lc = Cells(i, Columns.Count).End(xlToLeft).Column
    For j = 1 To lc
        If Cells(i, j).MergeArea.Cells(1).Value = Cells(i, j + 1).MergeArea.Cells(1).Value Then 'Or Cells(i, j) = Cells(i, j - 1) Then
            Range(Cells(i, j).MergeArea, Cells(i, j + 1)).Merge
        End If
    Next j
Next i
Range("A1").CurrentRegion.Borders.Color = vbBlack
End Sub

Answer 2

Sub Main()

    Dim i As Long
    Dim j As Long
    Dim rws As Long
    Dim clms As Long
    Dim strt As Range
    Dim endr As Range

    With ActiveSheet
        rws = .Cells(.Rows.Count, 1).End(xlUp).Row 'Find last row
        clms = .Cells(1, Columns.Count).End(xlToLeft).Column 'Find last column

        For i = 1 To rws 'iterate rows
            Set strt = .Cells(i, 1) 'set start of range
            For j = 2 To clms + 1 'iterate columns plus one
                If strt.Value <> .Cells(i, j).Value Then 'check for change
                    Set endr = .Cells(i, j - 1) ' if change set end of range
                    Application.DisplayAlerts = False
                    .Range(strt, endr).Merge 'merge start to end
                    Application.DisplayAlerts = True
                    Set strt = .Cells(i, j) 'set new start range on new cell
                End If
            Next j
        Next i
        With .Range(.Cells(1, 1), .Cells(rws, clms)).Borders 'put border on entire range
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
    End With

End Sub