[Iska]

blackeangel, это может выглядеть примерно так:

Скрытый текст

Код:

Option Explicit

Sub Sample()
    Dim i As Integer
    Dim objRange As Range
    Dim PrevValue As Variant
    Dim objRange4Union As Range
    
    
    Application.DisplayAlerts = False
    
    With ActiveSheet.UsedRange
        With .Columns.Item(1).Cells
            Set objRange4Union = .Item(2, 1)
            PrevValue = objRange4Union.Value
        End With
            
        For i = 3 To .Rows.Count
            Set objRange = .Columns.Item(1).Cells.Item(i, 1)
            
            If PrevValue = objRange.Value Then
                Set objRange4Union = Union(objRange4Union, objRange)
            Else
                With objRange4Union
                    With .Offset(0, 1)
                        .UnMerge
                        .Merge
                        
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                    End With
                    
                    With .Offset(0, 2)
                        .UnMerge
                        .Merge
                        
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                    End With
                End With
                
                Set objRange4Union = objRange
            End If
            
            PrevValue = objRange.Value
        Next i
    End With
    
    With objRange4Union
        With .Offset(0, 1)
            .UnMerge
            .Merge
            
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        
        With .Offset(0, 2)
            .UnMerge
            .Merge
            
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    End With
    
    Application.DisplayAlerts = True
End Sub