Автоподбор высоты объединеных ячеек

[Eresiarh]

Выражу материальную благодарность в размере 2-3 сотен рублей на кошелек или сотовый.

[EducatedFool]

Код для перебора листов неоднократно встречался на форуме...

Попробуйте такой вариант:

Sub AutoFitMergedCellRowHeight(ByRef ra As Range)
    Dim CurrCell As Range, cell As Range, ma As Range: Dim col As Range, ro As Range
    For Each ro In ra.Rows
        maxRH = 0
        For Each cell In ro.Cells
            If cell.MergeCells And cell.Address = cell.MergeArea.Cells(1).Address Then
                Debug.Print cell.Address(, , , -1)
                Set ma = cell.MergeArea: newCW = 0
                With ma
                    cw = .Columns(1).ColumnWidth: .UnMerge
                    For Each col In .EntireColumn: newCW = newCW + col.ColumnWidth: Next
                    .Columns(1).ColumnWidth = newCW: .EntireRow.AutoFit
                    rh = .EntireRow.RowHeight: If rh > maxRH Then maxRH = rh
                    .Merge: .Columns(1).ColumnWidth = cw
                End With
            End If
        Next cell
        If maxRH > 0 Then ro.EntireRow.RowHeight = maxRH
    Next ro
End Sub

Sub ПримерИспользования()
    Application.ScreenUpdating = False
    Dim sh As Worksheet
    For Each sh In ThisWorkbook.Worksheets    ' перебираем все листы
        ' обрабатываем всю используемую область листа
        AutoFitMergedCellRowHeight sh.UsedRange
    Next sh
End Sub

[Eresiarh]

Спасибо, теперь понял, что куда, жаль что макрос долговат. Но все же как и обещал, завтра.

[valerij]

Сообщение от EducatedFool

Код для перебора

Игорь, а я так делаю, это правильно??

Sub Высота_Строк()
Rows("3:1365").Select
    Selection.RowHeight = 15.75
    Range("d3").Select
End Sub

[sorockinalex]

Спасибо огромное! Весь интернет перерыл, нашёл что надо!!! Супер! Долговто только работает при автоматическом режиме.. А если назначить отдельно необходимые ячейки - то норм ))) Спасибо!