Подбор высоты строки/ширины столбца объединенной ячейки
Для начала немного теории. Если в ячейках листа 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 и выбрав
Чтобы было нагляднее - я приложил пример, в котором помимо самих кодов есть вырезка из стандартной накладной. Именно в таких документах наиболее часто встречаются подобные казусы и необходимость подбирать высоту и ширину объединенных ячеек.
Tips_Macro_HeightWidthInMergeCell.xls (64,0 KiB, 3 444 скачиваний)
Если подобную операцию приходится производить постоянно - советую коды записать в надстройку: Как создать свою надстройку?. Так же можно воспользоваться уже готовым решением в составе MulTEx - Высота/Ширина объединенной ячейки.
Статья помогла? Поделись ссылкой с друзьями!

Поиск по меткам
Access apple watch Multex Power Query и Power BI VBA управление кодами Бесплатные надстройки Дата и время Записки ИП Надстройки Печать Политика Конфиденциальности Почта Программы Работа с приложениями Разработка приложений Росстат Тренинги и вебинары Финансовые Форматирование Функции Excel акции MulTEx ссылки статистикаКомментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум
Дмитрий, спасибо.
Один маленький нюанс. В некоторых ячейках остается одна или иногда две пустые строчки.
Это можно как нибудь исправить?
Тоже столкнулся с проблемой, что "В некоторых ячейках остается одна или иногда две пустые строчки" после отработки вашей функции RowColHeightForContent. Мне нужно было подобрать только высоту ячейки, полученной объединением 6 ячеек одной строки. Если подвести мышку к границе столбца, то Excel показывает его ширину, причём два значения. В скобках показано значение в пикселях. У меня были такие значения: 4,57 (37); 23,57 (170); 9,71 (73); 20,57 (149); 14,43 (106) и 18,14 (132). Сумма получается 90,99 (667). Если теперь взять и попробовать растянуть первый столбец до значения 90,99, то ширина получается заметно меньше ширины объединённой ячейки, кстати значение в пикселях для 91,00 - 642. Соответственно и AutoFit выравнивает текст не на всю ширину объединённой ячейки. Порылся в Интернете нашёл решение (https://excelvba.ru/code/ColumnWidth ):
вместо MergedC_Widht = CurrCell.ColumnWidth + MergedC_Widht
использовать MergedC_Widht = CurrCell.Width / 0.75 + MergedC_Widht
и
вместо .Cells(1, 1).EntireColumn.ColumnWidth = MergedC_Widht
использовать .Cells(1, 1).EntireColumn.ColumnWidth = 1 + (MergedC_Widht - 12) / 7
Думаю с высотой надо делать что-то похожее, но такой задачи у меня не стояло.
Правда, всё равно, пустые строки внизу иногда появляются, но это уже проблема масштабирования шрифтов, как я понял. При определённом масштабе, у меня например при 110%, текст расползается и занимает последнюю строку, которая пустует при 100%.
Да, спасибо. Эту проблему я знаю, но беда в том, что даже озвученный подход не всегда корректно сработает. Эти "накидочки" маленькие - это попытка учесть границы между объединяемыми ячейками, которые тоже могут иметь разную ширину и тоже много от чего зависят. И в итоге опять же недоработка :) Поэтому оставил как есть, т.к. даже сам MS не всегда может нормально высоту строк подобрать - все зависит от применяемых шрифтов.
Спасибо еще раз. Оказывается модуль корректно работает под шрифтом Ариал. На других шрифтах остаются пустые строки.
Дмитрий, огромное Вам спасибо за данные макросы!
Подскажите, пожалуйста, как можно пройтись сразу по одному столбцу каждого листа в книге, а не выделать отдельно каждый диапазон, в котором надо подобрать высоту?
Вполне себе очень даже приятный макрос ))
может кому пригодится, вариант для вызова из vbscript
и вызов например
Спасибо!
Можно ли каким-то способом определить, что в ячейку текст не влез (не весть отображается)?
Павел, можно попробовать так:
При подсчете MergedC_Widht для ColumnWidth может получится значение больше 255 И как тогда быть?
Сергей, вопрос выглядит как претензия прям :)
Ну а ответ очевидный - проверять, чтобы ширина не выходила за эти пределы: