How to combine or merge cells with the same values vertically and horizontally , Excel VBA?

Question

I have sheet with same data in adjacent cells,I could to merge same cells on column A. now I need to merge or combine adjacent same cells beside merged cells on column A , meaning if A2:A3 is same that will be merged and subsequently merge B2:B3 ,C2:C3, D2:D3 until column L.

Update: any method other than Merge will be good also

Sub Merge_Similar_Cells()

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
     
    Dim LastRow As Long
    Dim ws As Worksheet
    Dim WorkRng As Range
    
    Set ws = ActiveSheet
    
    ws.AutoFilter.ShowAllData
    ws.AutoFilter.Sort.SortFields.Clear
    
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
     
    ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws.AutoFilter.Sort.Apply
                                                                                     
    Set WorkRng = ws.Range("A2:A" & LastRow)

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

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

Answer 1

Please, test the next code:

Sub Merge_Similar_Cells()
    Dim LastRow As Long, ws As Worksheet, arrWork, i As Long, j As Long, k As Long
    
    Set ws = ActiveSheet
    
    If ws.AutoFilterMode Then 'for the case when the sheet range is not filtered
        ws.AutoFilter.ShowAllData
        ws.AutoFilter.Sort.SortFields.Clear
    End If
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
     
    ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws.AutoFilter.Sort.Apply
                                                                                     
    arrWork = ws.Range("A1:A" & LastRow).Value2 'place the range in an array to make iteration faster
    
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    For i = 2 To UBound(arrWork) - 1            'iterate between the array elements:
        If arrWork(i, 1) = arrWork(i + 1, 1) Then
            'determine how many consecutive similar rows exist:_________
            For k = 1 To LastRow
                If i + k + 1 >= UBound(arrWork) Then Exit For
                If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
            Next k '____________________________________________________
            For j = 1 To 12
                ws.Range(ws.Cells(i, j), ws.Cells(i + k, j)).Merge 'merge all the necessary cells based on previously determined k
           Next j
           ws.Range(ws.Cells(i, 1), ws.Cells(i + k, 12)).VerticalAlignment = xlCenter 'apply vertical alignment for all obtained merged row
         i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'increment the i variable and exiting if the resulted value exits the array size
       End If
    Next i
    Application.DisplayAlerts = True: Application.ScreenUpdating = True
    MsgBox "Ready..."
End Sub

Edited:

Please, try the next code, which does not merge similar rows on identic column. It delete the similar rows, keeping only one and append the cells values in the range "M:P", separated by vbLf (placing on a separate row in the same cell):

Sub DeleteSimilarRows_AppendLastColuns()
    Dim LastRow As Long, ws As Worksheet, arrWork, rngDel As Range, i As Long, j As Long, k As Long
    Dim strVal As String, m As Long, boolNoFilter As Boolean
    
    Set ws = ActiveSheet
    
    If ws.AutoFilterMode Then             'for the case when the sheet range is not filtered
        ws.AutoFilter.ShowAllData
        ws.AutoFilter.Sort.SortFields.Clear
        
        LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row: boolNoFilter = True
        
        ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ws.AutoFilter.Sort.Apply
    End If
    
     If Not boolNoFilter Then LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    arrWork = ws.Range("A1:A" & LastRow).Value2 'place the range in an array to make iteration faster
    
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    For i = 2 To UBound(arrWork) - 1                  'iterate between the array elements:
        If arrWork(i, 1) = arrWork(i + 1, 1) Then
            'determine how many consecutive similar rows exist:______
            For k = 1 To LastRow
                If i + k + 1 >= UBound(arrWork) Then Exit For
                If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
            Next k '_________________________________________
            For j = 13 To 16                  'build the concatenated string of cells in range "M:P":
                strVal = ws.Cells(i, j).Value
                For m = 1 To k
                    strVal = strVal & vbLf & ws.Cells(i + m, j).Value
                Next m
                ws.Cells(i, j).Value = strVal: strVal = ""
           Next j
           For m = 1 To k                    'place the cells for rows to be deleted in a Union range, to delete at the end, at once
                If rngDel Is Nothing Then
                     Set rngDel = ws.Range("A" & i + m)
                Else
                    Set rngDel = Union(rngDel, ws.Range("A" & i + m))
                End If
         Next m
         i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'increment the i variable and exiting if the resulted value exits the array size
       End If
    Next i
    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete    'delete the not necessary rows
    ws.UsedRange.EntireRow.AutoFit: ws.UsedRange.EntireColumn.AutoFit
    Application.DisplayAlerts = True: Application.ScreenUpdating = True
    MsgBox "Ready..."
End Sub