Sub MergeCellsAutofit(R As Range) 'Форматирование объединенных ячеек с переносом по высоте
  Dim wR As Range, Row As Range, C As Range, _
      HrAlg, CurH, NewH
 
  Set wR = Application.Intersect(R, R.Worksheet.UsedRange)
 
  For Each Row In wR.Rows
    CurH = Row.RowHeight
    NewH = CurH
    For Each C In Row.Cells
      If C.MergeCells And C.WrapText And C.Column = C.MergeArea.Column And C.MergeArea.Rows.Count = 1 Then
        Set Ar = C.MergeArea
        HrAlg = C.HorizontalAlignment
        Ar.MergeCells = False
        Ar.HorizontalAlignment = xlCenterAcrossSelection
        Ar.Rows.AutoFit
        If NewH < Ar.RowHeight Then
          NewH = Ar.RowHeight
        End If
        Ar.RowHeight = NewH
        Ar.MergeCells = True
        Ar.HorizontalAlignment = HrAlg
      End If
    Next
    Row.RowHeight = NewH
  Next
End Sub