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

Хитрости »

10 Август 2016              35691 просмотров

Подбор высоты строки/ширины столбца объединенной ячейки

Для начала немного теории. Если в ячейках листа Excel записан некий длинный текст, то обычно устанавливают перенос на строки(вкладка Главная -группа Выравнивание —Перенос текста), чтобы текст не растягивался на весь экран, а умещался в ячейке. При этом высота ячейки тоже должна измениться, чтобы отобразить все содержимое. Если речь идет всего об одной простой ячейке — проблем не возникает. Обычно, чтобы установить высоту строки на основании содержимого ячейки, достаточно навести курсор мыши в заголовке строк на границу строки(курсор приобретет вид направленных в разные стороны стрелок — ) и дважды быстро щелкнуть левой кнопкой мыши. Тоже самое можно сделать и для ширины столбцов.
Но с объединенными ячейками такой фокус не прокатывает — ширина и высота для этих ячеек так не подбирается, сколько ни щелкай и приходится вручную подгонять каждую, чтобы текст ячейки отображался полностью:

Стандартными средствами такой автоподбор не сделать, но вот при помощи VBA — без проблем. Ниже приведена функция, которая поможет подобрать высоту и ширину объединенных ячеек на основании их содержимого.

'---------------------------------------------------------------------------------------
' Procedure : RowHeightForContent
' Author    : The_Prist(Щербаков Дмитрий)
'             http://www.excel-vba.ru
' Purpose   : Функция подбирает высоту строки/ширину столбца объединенных ячеек по содержимому
'---------------------------------------------------------------------------------------
Function RowColHeightForContent(rc As Range, Optional bRowHeight As Boolean = True)
'rc -         ячейка, высоту строки или ширину столбца которой необходимо подобрать
'bRowHeight - True - если необходимо подобрать высоту строки
'             False - если необходимо подобрать ширину столбца
    Dim OldR_Height As Single, OldC_Widht As Single
    Dim MergedR_Height As Single, MergedC_Widht As Single
    Dim CurrCell As Range
    Dim ih As Integer
    Dim iw As Integer
    Dim NewR_Height As Single, NewC_Widht As Single
    Dim ActiveCellHeight As Single
 
    If rc.MergeCells Then
        With rc.MergeArea 'если ячейка объединена
            'запоминаем кол-во столбцов
            iw = .Columns(.Columns.Count).Column - rc.Column + 1
            'запоминаем кол-во строк.
            ih = .Rows(.Rows.Count).Row - rc.Row + 1
            'Определяем высоту и ширину объединения ячеек
            MergedR_Height = 0
            For Each CurrCell In .Rows
                MergedR_Height = CurrCell.RowHeight + MergedR_Height
            Next
            MergedC_Widht = 0
            For Each CurrCell In .Columns
                MergedC_Widht = CurrCell.ColumnWidth + MergedC_Widht
            Next
            'запоминаем высоту и ширину первой ячейки из объединенных
            OldR_Height = .Cells(1, 1).RowHeight
            OldC_Widht = .Cells(1, 1).ColumnWidth
            'отменяем объединение ячеек
            .MergeCells = False
            'назначаем новую высоту и ширину для первой ячейки
            .Cells(1).RowHeight = MergedR_Height
            .Cells(1, 1).EntireColumn.ColumnWidth = MergedC_Widht
            'если необходимо изменить высоту строк
            If bRowHeight Then
                '.WrapText = True 'раскомментировать, если необходимо принудительно выставлять перенос текста
                .EntireRow.AutoFit
                NewR_Height = .Cells(1).RowHeight    'запоминаем высоту строки
                .MergeCells = True
                If OldR_Height < (NewR_Height / ih) Then
                    .RowHeight = NewR_Height / ih
                Else
                    .RowHeight = OldR_Height
                End If
                'возвращаем ширину столбца первой ячейки
                .Cells(1, 1).EntireColumn.ColumnWidth = OldC_Widht
            Else 'если необходимо изменить ширину столбца
                .EntireColumn.AutoFit
                NewC_Widht = .Cells(1).EntireColumn.ColumnWidth    'запоминаем ширину столбца
                .MergeCells = True
                If OldC_Widht < (NewC_Widht / iw) Then
                    .ColumnWidth = NewC_Widht / iw
                Else
                    .ColumnWidth = OldC_Widht
                End If
                'возвращаем высоту строки первой ячейки
                .Cells(1, 1).RowHeight = OldR_Height
            End If
        End With
    End If
End Function

Пара замечаний:

• т.к. нельзя выставить и автоширину и автовысоту — то функция подбирает либо высоту, либо ширину, что логично
• чтобы подбор по высоте ячеек сработал, для ячейки должен быть выставлен перенос строк(вкладка Главная -группа Выравнивание —Перенос текста). Если ячеек много и выставлять вручную лень — можно просто убрать апостроф перед точкой в строке:’.WrapText = True ‘раскомментировать, если необходимо принудительно выставлять перенос текстатогда код сам проставит переносы. Но тут следует учитывать, что в данном случае перенос будет выставлен для всех ячеек, что не всегда отвечает условиям
• функция подбирает высоту и ширину исключительно для объединенных ячеек. Если ячейка не объединена — код оставит её без изменений

Теперь о том, как это работает и как применять. Для начала необходимо приведенный выше код функции вставить в стандартный модуль. Сама по себе функция работать не будет — её надо вызывать из другого кода, который определяет какие ячейки обрабатывать. В качестве такого кода я предлагаю следующий:

Sub ChangeRowColHeight()
    Dim rc As Range
    Dim bRow As Boolean
    bRow = (MsgBox("Изменять высоту строк?", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbYes)
    'bRow = True:  для изменения высоты строк
    'bRow = False: для изменения ширины столбцов
    Application.ScreenUpdating = False
    For Each rc In Selection
        RowColHeightForContent rc, bRow
    Next
    Application.ScreenUpdating = True
End Sub

Этот код также необходимо вставить в стандартный модуль. Теперь его можно будет вызвать из этой книги, нажатием клавиш Alt+F8 и выбрав ChangeRowColHeight, или создав на листе кнопку и назначив ей макрос. После этого достаточно будет выделить диапазон ячеек, среди которых есть объединенные и вызвать макрос ChangeRowColHeight. Для всех объединенных ячеек в выделенном диапазоне будет подобрана высота или ширина.
Чтобы было нагляднее — я приложил пример, в котором помимо самих кодов есть вырезка из стандартной накладной. Именно в таких документах наиболее часто встречаются подобные казусы и необходимость подбирать высоту и ширину объединенных ячеек.
Скачать пример:

  Tips_Macro_HeightWidthInMergeCell.xls (64,0 KiB, 3 476 скачиваний)

Если подобную операцию приходится производить постоянно — советую коды записать в надстройку: Как создать свою надстройку?. Так же можно воспользоваться уже готовым решением в составе MulTEx — Высота/Ширина объединенной ячейки.

Статья помогла? Поделись ссылкой с друзьями!

    Видеоуроки

Поиск по меткам



Access
apple watch
Multex
Power Query и Power BI
VBA управление кодами
Бесплатные надстройки
Дата и время
Записки
ИП
Надстройки
Печать
Политика Конфиденциальности
Почта
Программы
Работа с приложениями
Разработка приложений
Росстат
Тренинги и вебинары
Финансовые
Форматирование
Функции Excel
акции MulTEx
ссылки
статистика

можно просто в этом блоке:

If OldR_Height < (NewR_Height / ih) Then
    .RowHeight = NewR_Height / ih
Else
    .RowHeight = OldR_Height
End If

оставить только одну строку:

.RowHeight = NewR_Height / ih

т.е. убрать условие на проверку высоты строки ДО, подбирая таким образом подо все строки без исключения. Не очень правильный подход, на мой взгляд, особенно если собрались для нескольких столбцов сразу применять. Если объединенные ячейки будут в разных столбцах, то высота будет подобрана на основании объединенных ячеек в последних столбцах.
Правильнее всего делать иначе: если это возможно, то перед выполнением цикла по ячейкам добавить строку установки стандартной высоты:

Sub ChangeRowColHeight()
    Dim rc As Range
    Dim bRow As Boolean
    bRow = (MsgBox("Изменять высоту строк?", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbYes)
    'bRow = True:  для изменения высоты строк
    'bRow = False: для изменения ширины столбцов
    Application.ScreenUpdating = False
    Selection.EntireRow.RowHeight = 12.75
    For Each rc In Selection
        RowColHeightForContent rc, bRow
    Next
    Application.ScreenUpdating = True
End Sub

еще правильнее делать это только в случае, если в строке есть хоть одна объединенная ячейка. Лень сейчас писать такой код, если честно. Но не сложный — можно просто выдернуть части из предложенных кодов и все.