Sub MergeAuto()

    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Cells.Count <= 1 Then Exit Sub
    Dim rColumn As Range, rCell As Range, sAddress$, rMerge As Range, rTarget As Range


Application.ScreenUpdating = False


    Set rTarget = Intersect(Selection, ActiveSheet.UsedRange)
    For Each rCell In rTarget
    If rCell.MergeCells Then
        sAddress = rCell.MergeArea.Address: rCell.UnMerge
        Range(sAddress).Value = rCell.Value
    End If
    Next
    rTarget.Select
    'Stop
    For Each rColumn In rTarget.Columns
    For Each rCell In rColumn.Cells
        If rMerge Is Nothing Then
            Set rMerge = rCell
        Else
            If rMerge(1).Value = rCell.Value Then
                Set rMerge = Union(rMerge, rCell): rMerge.Merge
            Else
                Set rMerge = rCell
            End If
        End If
    Next
    Set rMerge = Nothing
    Next


Application.ScreenUpdating = True

    
End Sub

Sub Перенос_объединения()
    Dim LastRow As Long
    LastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row ' последняя строка
    Application.ScreenUpdating = False
    Range(Cells(1, столбец_шаблона), Cells(LastRow, столбец_шаблона)).Copy ' копируем столбец с "шаблоном" объединений
    Range(Cells(1, столбец_применения_шаблона), Cells(LastRow, столбец_применения_шаблона)).PasteSpecial xlPasteFormats ' "применяем "шаблон" (форматы)
    Application.ScreenUpdating = True
End Sub