Attribute VB_Name = "Module1"
Sub AutoFitAllRows() ' автоподбор высоты объединенных ячеек
Dim rCell As Range, rMergeArea, maxMergeArea As Range
Dim rColumn As Range, rRow As Range, rRow1 As Range
Dim maxRowHeight!, newCellWidth!, CellWidth!, RowHeight!, CellHeight!, nOldAlignment!
Dim oSheet As Worksheet, oOldSheet As Worksheet
Dim stRowsWithShapes As String, oShape As Shape
    Set oOldSheet = Application.ActiveWorkbook.ActiveSheet
    Application.ScreenUpdating = False
    On Error Resume Next
    For Each oSheet In Application.ActiveWorkbook.Worksheets
        oSheet.Activate
        stRowsWithShapes = ""
        If (oSheet.Shapes.Count > 0) Then
            For Each oShape In oSheet.Shapes
                stRowsWithShapes = stRowsWithShapes & "," & oShape.TopLeftCell.Row
            Next oShape
            stRowsWithShapes = stRowsWithShapes & ","
        End If
    ' цикл по всем строкам диапазона
    For Each rRow In ActiveSheet.UsedRange.Rows
            If rRow.RowHeight > 0 And Not (stRowsWithShapes Like ("*," & rRow.Row & ",*")) Then
                maxRowHeight = 0
                ' цикл по всем ячейкам строки
                For Each rCell In rRow.Cells
                    If (Not rCell.MergeCells And rCell.MergeArea.Cells(1).Text <> "" And rCell.MergeArea.Cells(1).WrapText) Or (rCell.MergeCells And rCell.Address = rCell.MergeArea.Cells(1).Address) Then ' если это первая ячейкам объединенной области
                        Set rMergeArea = rCell.MergeArea
                        newCellWidth = 0
                        With rMergeArea
                            CellHeight = 0     ' запомним высоту в объединенной области без первой строки (для объединенных по вертикали)
                            CellWidth = .Columns(1).ColumnWidth ' запомним ширину первого столюца в объединенной области
                            If CellWidth > 0 Then  ' метод 1 (через выравнивание по центру выделения)
								If IsNull(.HorizontalAlignment) Then
                                    nOldAlignment = rMergeArea(1, 1).HorizontalAlignment
                                Else
                                    nOldAlignment = .HorizontalAlignment
                                End If
                                'Разгруппировать
                                .UnMerge
                                .HorizontalAlignment = xlCenterAcrossSelection
                                .VerticalAlignment = xlTop
                                'Автоподбор
                                .WrapText = True 'переносить по словам
                                .EntireRow.AutoFit
                                ' запомнить подобранную высоту для этой объединенной области
                                RowHeight = .EntireRow.Rows(1).RowHeight
                                'Снова объединить
                                .Merge
                                .HorizontalAlignment = nOldAlignment
                                ' если подобранная высота для этой объединенной области максимальна в строке, то запомним её
                                If (.EntireRow.Rows(1).Height > maxRowHeight) Then
                                    maxRowHeight = RowHeight
                                    Set maxMergeArea = Range(Cells(rMergeArea.Row, rMergeArea.Column), Cells(rMergeArea.Row + rMergeArea.Rows.Count - 1, rMergeArea.Column + rMergeArea.Columns.Count - 1))
                                End If
                            Else                ' метод 2 (через подгон высоты в одной колонке, равной по ширене объединенной)
                                .UnMerge ' разгруппировываем область
                                For Each rColumn In .EntireColumn: newCellWidth = newCellWidth + rColumn.ColumnWidth: Next
                                For Each rRow1 In .EntireRow: CellHeight = CellHeight + rRow1.RowHeight: Next
                                CellHeight = CellHeight - .Rows(1).RowHeight
                                .Columns(1).ColumnWidth = IIf(newCellWidth > 255, 255, newCellWidth) ' делаем ширину первой ячейки такую же, как была у всей объединенной области
                                .EntireRow.Rows(1).AutoFit ' автоподбор высоты первой ячейки объединенной области
                                RowHeight = .EntireRow.Rows(1).RowHeight - CellHeight ' запомнить подобранную высоту для этой объединенной области
                                If RowHeight > maxRowHeight Then maxRowHeight = RowHeight ' если подобранная высота для этой объединенной области максимальна в строке, то запомним её
                                .Merge ' группируем область обратно
                                .Columns(1).ColumnWidth = CellWidth ' восстановим ширину первого столюца
                            End If
                        End With
                    End If
                Next rCell ' повторяем со следующей ячейкой строки
                ' устанавливаем подобранную максимальную высоту строки для 1-го варианта
                If (maxRowHeight > 0 And CellWidth > 0) Then
                    Dim irow, NewHeight As Integer
                    Dim H1, H2 As Integer
                    With maxMergeArea
						If IsNull(.HorizontalAlignment) Then
							nOldAlignment = rMergeArea(1, 1).HorizontalAlignment
						Else
							nOldAlignment = .HorizontalAlignment
						End If
                        'Разгруппировать
                        .UnMerge
                        .HorizontalAlignment = xlCenterAcrossSelection
                        .VerticalAlignment = xlTop
                        'Автоподбор
                         .WrapText = False 'не переносить по словам
                        .EntireRow.AutoFit
                        H1 = .EntireRow.Rows(1).RowHeight
                        'Автоподбор
                        .WrapText = True 'переносить по словам
                        .EntireRow.AutoFit
                        H2 = .EntireRow.Rows(1).RowHeight
                        ' запомнить подобранную высоту для этой объединенной области
                        RowHeight = .EntireRow.Rows(1).RowHeight
                        'Снова объединить
                        .Merge
                        .HorizontalAlignment = nOldAlignment
                         'Распределить высоту между строками
						 'Если текст помещается в одну строку, обычно высотой 14.04
                         If (H2 - H1 < 14.00) Then
                             NewHeight = H2
                         Else
                            'Если было расширение, то распределить высоту между объединенных строк
                             NewHeight = RowHeight / .Rows.Count
                         End If
                        'присвоить строкам новую высоту
                        For Each Row In .Cells.Rows
                            Row.RowHeight = NewHeight
                        Next Row
                    End With
                    ElseIf (CellWidth <= 0) Then 'для 2-го варианта
                       If maxRowHeight > 0 Then rRow.EntireRow.RowHeight = maxRowHeight ' устанавливаем подобранную максимальную высоту строки
                End If                
            End If
        Next rRow ' переходим к следующей строке
    Next oSheet
    oOldSheet.Activate
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub