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

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

Loading

12 комментариев

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

    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%.

      1. Да, спасибо. Эту проблему я знаю, но беда в том, что даже озвученный подход не всегда корректно сработает. Эти "накидочки" маленькие - это попытка учесть границы между объединяемыми ячейками, которые тоже могут иметь разную ширину и тоже много от чего зависят. И в итоге опять же недоработка :) Поэтому оставил как есть, т.к. даже сам MS не всегда может нормально высоту строк подобрать - все зависит от применяемых шрифтов.

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

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

    может кому пригодится, вариант для вызова из 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)

    Спасибо!

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

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

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

      If MergedC_Widht > 255 Then
    MergedC_Widht = 255
end if

  7. Много более короткий код, но только для подбора высоты строки и только объединённые столбцы. При желании можно чуть трансформировать и для остальных случаев. VBA Excel.

    Function RowHeightAutoFit(rRange As Range, SheetName As String) 'Sub proba()
 
Dim iHeight As Integer, iWidth%, iTmp1%, iTmp2%
Dim sValue As String
 
With rRange
    sValue = .Cells(1).Value2
    iHeight = .Cells(1).RowHeight
    iWidth = .Cells(1).ColumnWidth * .Columns.Count
    With ThisWorkbook.Worksheets(SheetName).Range("Для_подбора_высоты")
        iTmp1 = .RowHeight
        iTmp2 = .ColumnWidth
        .ColumnWidth = iWidth
        .Value2 = sValue
        .WrapText = True
        .EntireRow.AutoFit
        iHeight = .RowHeight
        .RowHeight = iTmp1
        .ColumnWidth = iTmp2
        .Value2 = ""
    End With
    .RowHeight = iHeight
End With
 
End Function

  8. Здравствуйте!
    Дмитрий, ниже модернизированный код с комментариями и, если сочтёте нужным, просьба заменить мой предыдущий вариант.
    '------------------------------------------------------------------------------------------------------------------
    'Функция принимает:
    '1. rRange - ссылку на изменяемый по высоте диапазон (ВНИМАНИЕ! только с одной строкой, другими словами, объединены
    ' только столбцы);
    '2. SheetName - строковое значение имени листа, на котором находится rRange;
    '3. Значения ограничений по высоте iMinLim и iMaxLim принимает опционально, то есть можно и не указывать.
    'Концепция.
    'Необходима вспомогательная ячейка на листе (функция принимает имя листа SheetName) и в коде функции такая ячейка
    'имеет именованный диапазон .Range("Для_подбора_высоты"). ВНИМАНИЕ! вам необходимо заранее позаботиться о создании
    'на вашем листе такой ячейки (где-нибудь за областью печати или вне видимости пользователя) с именем "Для_подбора_
    'высоты" (именованный диапазон). Вспомогательная ячейка принимает содержимое изменяемого по высоте диапазона (пере-
    'менная sValue) и ширину (переменная iWidth) данного диапазона (rRange). Затем, применяем к вспомогательной ячейке
    'функцию AutoFit и сохраняем полученную высоту строки в переменную iHeight.
    'Применяем к rRange в качестве параметра высоты строки значение переменной iHeight и при этом проверяем условия на
    'ограничения высоты (функция может, если необходимо, принимать ограничения iMinLim и iMaxLim). Также, не забываем
    'вернуть вспомогательной ячейке прежние её высоту и ширину (переменные iTmp1 и iTmp2).
    '----------------------------------------------------------------------------------------------------------------

    Function RowHeightAutoFit(ByRef rRange As Range, ByVal SheetName As String, Optional ByVal iMinLim As Integer = 0, Optional ByVal iMaxLim As Integer = 0) 'Sub proba()

    Dim iHeight As Integer, i%, iWidth%, iTmp1%, iTmp2%
    Dim sValue As String

    With rRange 'работаем с изменяемым по высоте диапазоном
    sValue = .Cells(1).Value2 'содержимое
    For i = 1 To .Columns.Count 'так суммируем ширины объединённых столбцов в изм. диапазоне
    iWidth = iWidth + .Cells(i).ColumnWidth
    Next i
    'Работаем со вспомогательной ячейкой.
    With ThisWorkbook.Worksheets(SheetName).Range("Для_подбора_высоты")
    iTmp1 = .RowHeight 'записываем изначальное знач. высоты
    iTmp2 = .ColumnWidth 'записываем изначальное знач. ширины
    .ColumnWidth = iWidth 'изменяем ширину
    .Value2 = sValue 'вставляем содержимое
    .WrapText = True 'обязательно включаем перенос текста по строкам внутри ячейки
    .EntireRow.AutoFit 'активируем функцию AutoFit
    iHeight = .RowHeight 'записываем полученное значение высоты строки
    .RowHeight = iTmp1 'возвращаем изначальную высоту
    .ColumnWidth = iTmp2 'возвращаем изначальную ширину
    .Value2 = "" 'очищаем содержимое
    End With
    'Ниже в соответствии с условиями на ограничения высоты, если были приняты такие, изменяем высоту нашего диапазона rRange.
    If iMinLim = 0 And iMaxLim = 0 Then 'ограничений не поступало
    .RowHeight = iHeight
    ElseIf iMinLim = 0 And iMaxLim > 0 Then 'если функция приняла только максимальное ограничение
    If iHeight > iMaxLim Then
    .RowHeight = iMaxLim
    Else
    .RowHeight = iHeight
    End If
    ElseIf iMinLim > 0 And iMaxLim = 0 Then 'если функция приняла только минимальное ограничение
    If iHeight 0 And iMaxLim > 0 Then 'если функция приняла минимальное и максимальное ограничение
    If iHeight > iMinLim And iHeight < iMaxLim Then
    .RowHeight = iHeight
    ElseIf iHeight iMaxLim Then
    .RowHeight = iMaxLim
    End If
    End If
    End With

    End Function

Добавить комментарий

This site uses Akismet to reduce spam. Learn how your comment data is processed.