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