Lost your password?


Хитрости »
Основные понятия (26)
Сводные таблицы и анализ данных (10)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (22)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (68)
Разное (43)
Баги и глюки Excel (4)

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

Для начала немного теории. Если в ячейках листа 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 444 скачиваний)

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


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

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

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

    Дмитрий, спасибо.
    Один маленький нюанс. В некоторых ячейках остается одна или иногда две пустые строчки.
    Это можно как нибудь исправить?

    • Дмитрий:

      Тоже столкнулся с проблемой, что "В некоторых ячейках остается одна или иногда две пустые строчки" после отработки вашей функции 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 не всегда может нормально высоту строк подобрать - все зависит от применяемых шрифтов.

  2. Спантомано.:

    Спасибо еще раз. Оказывается модуль корректно работает под шрифтом Ариал. На других шрифтах остаются пустые строки.

  3. LeoNeon:

    Дмитрий, огромное Вам спасибо за данные макросы!
    Подскажите, пожалуйста, как можно пройтись сразу по одному столбцу каждого листа в книге, а не выделать отдельно каждый диапазон, в котором надо подобрать высоту?

  4. ef1:

    Вполне себе очень даже приятный макрос ))

    может кому пригодится, вариант для вызова из vbscript

    Function RowColHeightForContent(xlsDoc, shName, rangeAddrStr, bRowHeight)
    'xlsDoc - документ Excel   (обязательно передавать документ, листа недостаточно)
    'shName - имя лист рабочей книги Excel
    ...
        Set wSheet = xlsDoc.Worksheets(shName)
        Set rc = wSheet.Range(rangeAddrStr)
     
        With wSheet
        If rc.MergeCells Then
            wSheet.Application.ScreenUpdating = False
    ...
            wSheet.Application.ScreenUpdating = True
    ...

    и вызов например

        Set ExcellApp = CreateObject("Excel.Application")
        Set xlDoc = ExcellApp.Workbooks.Open("C:Users......xlsx")
        Set xlSheet = xlDoc.Worksheets("TDSheet")
        Call RowColHeightForContent(xlDoc, xlSheet.Name, xlSheet.Cells(2, 6).Address, True)

    Спасибо!

  5. Павел:

    Можно ли каким-то способом определить, что в ячейку текст не влез (не весть отображается)?

    • Павел, можно попробовать так:

      If Len(Cells(1,1).Value) > Len(Cells(1,1).Text) then
          Msgbox "Текст не уместился",vbInformation, "www.excel-vba.ru"
      end if
  6. Sergey:

    При подсчете MergedC_Widht для ColumnWidth может получится значение больше 255 И как тогда быть?

    • Сергей, вопрос выглядит как претензия прям :)
      Ну а ответ очевидный - проверять, чтобы ширина не выходила за эти пределы:

      If MergedC_Widht > 255 Then
          MergedC_Widht = 255
      end if
Поделитесь своим мнением

Комментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум


Для оформления сообщений Вы можете использовать следующие тэги:
<a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

Тренинги

Заказать
Юридическая информация

Использование материалов сайта

Политика Конфиденциальности

ИП Щербаков Дмитрий Валентинович
ОГРНИП: 318502700083307
ИНН: 504013350772

Наши партнеры

Перейти
Перейти

Счетчики

Рейтинг@Mail.ru Яндекс.Метрика
© 2023 Excel для всех   Войти