mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

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

Предлагаю 2 варианта автоподбора высоты объединённых ячеек в Excel
(оба работаю не идеально, - но, тем не менее, в большинстве случаев и этого будет достаточно)

1 вариант: (разъединение, автоподбор, объединение)

Sub AutoFitMergeAreaSize(ByRef cell As Range)
    Dim ra As Range: Set ra = cell.MergeArea
    cell.UnMerge
    cell.EntireRow.AutoFit
    ra.Merge
End Sub
 
Sub ПримерИспользования_АвтоподборВысотыОбъединённойЯчейки()
    AutoFitMergeAreaSize ActiveCell
    AutoFitMergeAreaSize [d3]
End Sub

2 вариант:(то же самое, по сути, только кода побольше)

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
                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
    AutoFitMergedCellRowHeight [a2:z8]
End Sub

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Пример()
AutoFitMergeAreaSize ActiveCell
AutoFitMergeAreaSize [d3]
End Sub
А если нужно обратится к ячейке с другого листа? Как быть?

Вы достойный человек! Спасибо :)

>>Тогда надо бы, наверное, в варианте 2 на этой странице подправить:
вместо rh = .EntireRow.RowHeight
написать rh = .Item(1).RowHeight

Работать будет, но высота подбираться станет некорректно. Не случайно я в макросе делаю поправку на высоту видимых строк. Вообщем, смотрите код на планете.

Ув. EducatedFool, Ваш пример http://excelvba.ru/XL_Files/Sample__30-07-2011__15-31-17.zip лечится обратным проходом по строкам.

Спасибо за ответ. Я уже на Планете в том топике посмотрел и всё понял: возвращается высота не одной строки, а нескольких.
Тогда надо бы, наверное, в варианте 2 на этой странице подправить:
вместо rh = .EntireRow.RowHeight
написать rh = .Item(1).RowHeight

Alex_ST, ни разу не сталкивался с подобным.
Не знаю, из-за чего это может происходить.
На 2 или 3 файлах тестировал этот код - и, если автоподбор высоты не всегда отрабатывает корректно, - то уж ошибок с вылетом макроса точно не было...
Имеет смысл спросить на форуме, прикрепив ваш файл с этим кодом.

Никак не могу разобраться почему если объединены ячейки ОДНОЙ строки, то второй макрос срабатывает нормально, а если объединены ячейки по вертикали, то после выполнения подбора высоты командой .EntireRow.AutoFit
диапазон .EntireRow становится = Nothing и, естественно, присвоение rh = .EntireRow.RowHeight вылетает по ошибке?

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _____          _____   _                _    
|___ | __ __ |___ | | | ____ / \
/ / \ \/ / / / | | |_ / / _ \
/ / > < / / | |___ / / / ___ \
/_/ /_/\_\ /_/ |_____| /___| /_/ \_\
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.