'Sub m1()
'Call AutoFitRows1("", 0, 0, 0, 0)
'End Sub
                    
'Sub m1()
'   Call AutoFitRows1("3", 0, 0, 0, 0)
'End Sub
    
Sub GetCoords(Xbeg As Integer, Ybeg As Integer, ByVal cntCol As Integer, ByVal cntRow As Integer, XEnd As Integer, YEnd As Integer)
    Dim fRange As Range
    Dim fCol, fRow As Integer
    fCol = 0
    fRow = 0
    
    '=====================================================================================
    'Ищем диапозон для обработки, если он не совсем задан
    '======================================================================================
    'Входные параметры для тестирования
    'Dim Xbeg As Integer, Ybeg As Integer, cntCol As Integer, cntRow As Integer
    '
    'Xbeg = 2
    'Ybeg = 6
    'cntCol = 247
    'cntRow = 4
                                                        
    If (Xbeg = 0 And Ybeg = 0) Then
        'Ищем конечную колонку по тексту "Top_AutoFitRows"
        Set fRange = ActiveSheet.Cells.Find(What:="Top_AutoFitRows", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
                                                        
        If Not fRange Is Nothing Then
            'Берём случай, когда это верхняя ячейка от диапозона, который размножается по строкам и столбцам
            'Поэтому прибаляем к ней 1 строку и 1 колонку
            If fRange.MergeCells = True Then
                Xbeg = fRange.MergeArea.Cells.Column + fRange.MergeArea.Cells.Columns.Count
                Ybeg = fRange.MergeArea.Cells.Row + fRange.MergeArea.Cells.Rows.Count
            Else
                Xbeg = fRange.Cells.Column + 1
                Ybeg = fRange.Cells.Row + 1
            End If
                                            
            'fRange.Value = ""
            fRange.Replace What:="Top_AutoFitRows", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        Else
            Xbeg = 1
            Ybeg = 1
        End If
    End If
                                                                    
    If (cntCol = 0) Then
        'Ищем конечную колонку по тексту "endCol_AutoFitRows"
        Set fRange = ActiveSheet.Cells.Find(What:="endCol_AutoFitRows", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
                                                        
        If Not fRange Is Nothing Then
            fCol = fRange.Column - 1
                                            
            'fRange.Value = ""
            fRange.Replace What:="endCol_AutoFitRows", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        End If
    End If
                                                                                    
    If (cntRow = 0) Then
        'Ищем конечную строку по тексту "endRow_AutoFitRows"
        Set fRange = ActiveSheet.Cells.Find(What:="endRow_AutoFitRows", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
                                                                                    
        If Not fRange Is Nothing Then
            fRow = fRange.Row - 1
                                            
            'fRange.Value = ""
            fRange.Replace What:="endRow_AutoFitRows", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        End If
    End If
                                                        
    'Индекс крайней правой колнки
    If cntCol <> 0 Then
        XEnd = Xbeg + cntCol - 1
    Else
        XEnd = fCol
    End If
    'Индекс нижней строки
    If cntRow <> 0 Then
        YEnd = Ybeg + cntRow - 1
    Else
        YEnd = fRow
    End If
End Sub
                    
'Макрос AutoFitRows1
'Назначение: автободбор высоты строк объединенных ячеек с распределением высоты между объединенными строками.
'Объединенные строки слева, не объедиеннеые  справа.
'Описание:
'Вызывает макрос AutoFitAllRows_Range на каждой из укзанных страниц
'Входные параметры:
'Pages - строка с номерами страниц(по порядку) через пробел
'Обрабатываемый диапазон:
'Xbeg - номер по порядку начальной колонки диапазона
'Ybeg - номер по порядку начальной строки диапазона
'cntCol - количетсво колонок вправо
'cntRow - количетсво строк вниз
'Если Xbeg = 0, Ybeg = 0, cntCol, cntRow -  то пробует определить диапазон по ячейкам,
'в которых прописан текст: Top_AutoFitRows, endCol_AutoFitRows, endRow_AutoFitRows
Sub AutoFitRows1(Pages As String, Xbeg As Integer, Ybeg As Integer, ByVal cntCol As Integer, ByVal cntRow As Integer) ' автоподбор высоты объединенных ячеек
    Dim oOldSheet As Worksheet
    Dim XbegNew As Integer, YbegNew As Integer
    Dim i As Integer
    Dim XEnd As Integer, YEnd As Integer
    Dim fRange, range1 As Range
    Dim fCol, fRow As Integer
    fCol = 0
    fRow = 0
        
    Worksheets(1).Activate
   
    '=====================================================================================
    'По страницам
    '=====================================================================================
     'Из-за особенности, что на клиенте, вместо параметра который прописан как строка, напрмер "2" сюда передается ""2""
    Pages = Replace(Pages, Chr(34), "")
    
    Dim allUsedRange As Boolean
    isNotCoord = True
   
    Set oOldSheet = Application.ActiveWorkbook.ActiveSheet
    'Вызываем на всех имеющихся страницах
    If Pages = "" Then
        For sheet1 = 1 To Sheets.Count
            Worksheets(sheet1).Activate
            XbegNew = Xbeg
            YbegNew = Ybeg
            XEnd = 0
            YEnd = 0
            Call GetCoords(XbegNew, YbegNew, cntCol, cntRow, XEnd, YEnd)
            If (XEnd <> 0 And YEnd <> 0) Then
                isNotCoord = False
                Set range1 = Range(Cells(YbegNew, XbegNew), Cells(YEnd, XEnd))
                Call AutoFitAllRows_Range(Worksheets(sheet1), range1)
            Else
                Exit For
            End If
        Next sheet1
    Else 'Вызываем на указанных страницах
        PageArray = Split(Pages, " ")
        arrCnt = UBound(PageArray)
        
        For sheet1 = 1 To Sheets.Count
            
            For i = 0 To arrCnt
                If Worksheets(sheet1).Index = CInt(PageArray(i)) Then
                    Worksheets(sheet1).Activate
                    XbegNew = Xbeg
                    YbegNew = Ybeg
                    XEnd = 0
                    YEnd = 0
                    Call GetCoords(XbegNew, YbegNew, cntCol, cntRow, XEnd, YEnd)
                    If (XEnd <> 0 And YEnd <> 0) Then
                        isNotCoord = False
                        Set range1 = Range(Cells(YbegNew, XbegNew), Cells(YEnd, XEnd))
                        Call AutoFitAllRows_Range(Worksheets(sheet1), range1)
                    End If
                    Exit For
                End If
            Next i
            
        Next sheet1
        Worksheets(1).Activate
    End If
    
    If (isNotCoord = True) Then
         For sheet1 = 1 To Application.ActiveWorkbook.Sheets.Count
            Worksheets(sheet1).Activate
            Set range1 = ActiveSheet.UsedRange
            Call AutoFitAllRows_Range(Worksheets(sheet1), range1)
        Next sheet1
    End If
    
    oOldSheet.Activate
End Sub
    
    
Sub AutoFitAllRows_Range(oSheet As Worksheet, range1 As Range) ' автоподбор высоты объединенных ячеек
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 stRowsWithShapes As String, oShape As Shape
    
    'Application.ScreenUpdating = False
    On Error Resume Next
    
    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 range1.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 Trim(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 As Integer
                Dim NewHeight As Currency
                
                Dim H1, H2 As Currency
                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
                     'Распределить высоту между строками
                     If (H2 - H1 < 14#) Then
                         NewHeight = H2
                     Else
                        'Если было расширение, то распределить высоту между объединенных строк
                                                    'Если текст помещается в одну строку, обычно высотой 14.04
                         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 ' переходим к следующей строке


    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub
