Sub MergeCell_AutoHeight()   ' автоподбор высоты объединенных ячеек в Selection
   If Intersect(ActiveWindow.RangeSelection, ActiveSheet.UsedRange) Is Nothing Then Exit Sub
   Application.ScreenUpdating = False
   Dim rCell As Range, rMergeArea As Range, rColumn As Range, rRow As Range
   Dim maxRowHeight!, newCellWidth!, CellWidth!, RowHeight!
   For Each rRow In Intersect(ActiveWindow.RangeSelection, ActiveSheet.UsedRange).Rows  ' цикл по всем строкам диапазона
      maxRowHeight = 0
      For Each rCell In rRow.Cells   ' цикл по всем ячейкам строки
         If rCell.MergeCells And rCell.Address = rCell.MergeArea.Cells(1).Address Then   ' если это первая ячейкам объединенной области
            Set rMergeArea = rCell.MergeArea: newCellWidth = 0
            With rMergeArea
               CellWidth = .Columns(1).ColumnWidth   ' запомним ширину первого столбца в объединенной области
               .UnMerge   ' разгруппировываем область
               For Each rColumn In .EntireColumn: newCellWidth = newCellWidth + rColumn.ColumnWidth: Next
               .Columns(1).ColumnWidth = newCellWidth   ' делаем ширину первой ячейки такую же, как была у всей объединенной области
               .EntireRow.AutoFit   ' автоподбор высоты первой ячейки объединенной области
               RowHeight = .Item(1).RowHeight   ' запомнить подобранную высоту для этой объединенной области
               'RowHeight = .EntireRow.RowHeight   ' запомнить подобранную высоту для этой объединенной области
               If RowHeight > maxRowHeight Then maxRowHeight = RowHeight   ' если подобранная высота для этой объединенной области максимальна в строке, то запомним её
               .Merge   ' группируем область обратно
               .Columns(1).ColumnWidth = CellWidth   ' восстановим ширину первого столбца
            End With
         End If
      Next rCell   ' повторяем со следующей ячейкой строки
      If maxRowHeight > 0 Then rRow.EntireRow.RowHeight = maxRowHeight   ' устанавливаем подобранную максимальную высоту строки
   Next rRow   ' переходим к следующей строке
   Application.ScreenUpdating = True
End Sub