Vba excel размер объединенной ячейки

Хитрости »

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

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

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

Что получилось у меня и чем пока пользуюсь. Описание кода, по возможности подробное, в самом коде.

Sub RowHeightFiting1()
‘ Объединённая ячейка должна быть активной!!!
Application.ScreenUpdating = False

Dim MyRanAdr As String
Dim MergeAreaTotalWidth, MergeAreaTotalHeight
Dim MergeAreaFirstCellColWidth, MergeAreaFirstCellColHeight
Dim SumCW, SumRH
Dim i As Integer
Dim NewRH
Dim dCW ‘

MyRanAdr = ActiveCell.MergeArea.Address ‘адрес области с объединённой ячейкой
MergeAreaTotalWidth = Range(MyRanAdr).Width ‘ ширина всей объединённой ячейки в ед. пт
MergeAreaTotalHeight = Range(MyRanAdr).Height ‘ высота всей объединённой ячейки в ед. пт
MergeAreaFirstCellColWidth = Range(MyRanAdr).Cells(1, 1).EntireColumn.ColumnWidth ‘ ширина первого столбца в объединённой ячейке
MergeAreaFirstCellColHeight = Range(MyRanAdr).Cells(1, 1).EntireRow.RowHeight ‘ высота первой строки в объединённой ячейке

‘ подсчёт суммарной ширины объед. ячейки в единицах ColumnWidth
SumCW = 0
For i = 1 To Range(MyRanAdr).Columns.Count
SumCW = SumCW + Range(MyRanAdr).Columns(i).ColumnWidth
Next

‘ Установка ширины первого столбца равной суммарной ширины объед. ячейки плюс поправка
‘ Поправка состоит из количества как бы «убранных» столбцов, умноженной на корректировочный коэффициент
Range(MyRanAdr).Cells(1, 1).ColumnWidth = SumCW + (Range(MyRanAdr).Columns.Count — 1) / 1.2 ‘ 1.2=3.75 / 4.5
‘ корректировочный коэффициент возникает из-за «краёв» каждого столбца

‘далее, при необходимости, максимально точная подгонка
dCW = 0.1 ‘ шаг изменения ширины столбца в единицах ColumnWidth при подгонке
sgndcw = Sgn(MergeAreaTotalWidth — Range(MyRanAdr).Cells(1, 1).Width)
SumCW = Range(MyRanAdr).Cells(1, 1).ColumnWidth
While sgndcw * (MergeAreaTotalWidth — Range(MyRanAdr).Cells(1, 1).Width) > 0
SumCW = SumCW + dCW * sgndcw
Range(MyRanAdr).Cells(1, 1).EntireColumn.ColumnWidth = SumCW
Wend
While MergeAreaTotalWidth — Range(MyRanAdr).Cells(1, 1).Width < 0
SumCW = SumCW — dCW
Range(MyRanAdr).Cells(1, 1).EntireColumn.ColumnWidth = SumCW
Wend
‘ хотя, вообще-то, обычно эта часть процедуры не нужна
‘ просто на случай, если поправка к ширине первого столбца вдруг окажется неверной. Напр., из-за того, что ширина стольца меняется дискретно с шагом 0.167, но не всегда.

‘ форматирование ячейки (устан. опции перенос текста и разобъединение ячейки)
Range(MyRanAdr).WrapText = True
Range(MyRanAdr).MergeCells = False

‘ применение Автоподбора высоты к необъединённой ячейке
Range(MyRanAdr).Cells(1, 1).EntireRow.AutoFit

‘ запись получившейся высоты в переменную
NewRH = Range(MyRanAdr).Cells(1, 1).EntireRow.RowHeight

‘ обратное объединение ячейки
Range(MyRanAdr).MergeCells = True

‘ принудительная установка высоты объединённой ячейки НО !!!:
‘ НО !!!: ТУТ ТОЛЬКО У ПЕРВОЙ СТРОКИ в случае, если объединённая ячейка состояла из нескольких строк
Range(MyRanAdr).Cells(1, 1).EntireRow.RowHeight = NewRH — (MergeAreaTotalHeight — MergeAreaFirstCellColHeight)
‘ Если нужно выровнять высоту строк, то можно использовать что-нибудь типа
‘Range(MyRanAdr).EntireRow.RowHeight = NewRH / Range(MyRanAdr).Rows.Count

‘ установка изначальной ширины первого столбца
Range(MyRanAdr).Cells(1, 1).EntireColumn.ColumnWidth = MergeAreaFirstCellColWidth

Application.ScreenUpdating = True
L: ‘ усё
i = MsgBox(«Das ist Fantastisch!» & Chr(10) & «Stimt das?», vbYesNo)
If i = vbNo Then GoTo L
End Sub

Глюков пока не замечал, но и не фантазировал в способах проверки
Впрочем, при большом количестве узких (менее примерно 3 симв) столбцов, входящих в объединённую ячейку или находящемся в ней длинном (более 100-150 символов) тексте (например, xls-фактуры, вытянутые из Консультант-плюс) может происходить следующее:
1. Новая высота объединённой ячейки выставляется как бы чуть-чуть «с запасом», т.е. больше, чем надо. Особенно в печатном виде. Но это, похоже, проблема самого Excelя.
2. Точная подгонка занимает ОЧЕНЬ много времени (более секунды). Просто процедура (там, где блок с While и написано, что эта часть обычно не используется) написана «в лоб» и совершенно неоптимизирована. Оставляю эту часть желающим на доделку. Или доделаю потом сам.

ЗЫ: В хелпе Office 97 не говорится о ReadOnly метода Width… А наоборот, Read and set…
Но на новый Office менять не могу, ибо с новым Office у меня внедрённые в лист Excelя картинки на печати выходят просто рамками.

Код

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

Написание статьи на эту тему назревало очень долго. Да, таких постов полно в интернете, но их всегда приходится искать.

Исходные данные

В Excel есть табличка со строками. Ширина колонок таблицы фиксирована, но изначально не известна. Ширина столбцов Excel фиксирована и равна 0,58. То есть одна ячейка таблицы с данными — это объединение нескольких ячеек самого Excel. Так же, все строки с данными таблицы в колонке А имеют значение «l«, а после таблицы весь футер содержит значение «f» (это исторически сложилось и сильно облегчает жизнь)

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

Теория

Excel не умеет выставлять автовысоту для объединенных ячеек, но умеет это делать для отдельной ячейки. Это значит, что алгоритм сводится к нескольким простым шагам:

1. Вычислить длину объединенной ячейки
2. Разбить ячейку на составляющие (на текст это никак не повлияет, поскольку он записан в первую ячейку объединенной области. Это даже нам на руку)
3. Выставить первой ячейке нужную длину
4. Выставить автовысоту
5. Вернуть длину первой ячейки
6. Объединить ячейки обратно

Реализация алгоритма

Sub AutoFitMergedCellRowHeight(ByRef ra As Range, ByRef cellWidth As Double)
    Dim CurrCell As Range
    Dim cell As Range
    Dim ma As Range: Dim col As Range, ro As Range
    Dim coef As Double
 
    coef = 1.66 ' Коэфициент границ ячеек
    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
 
                    If cellWidth = 0 Then
                        For Each col In .EntireColumn: newCW = newCW + col.ColumnWidth: Next
                        newCW = newCW * coef
                        cellWidth = newCW
                    Else
                        newCW = cellWidth
                    End If
 
                    .Columns(1).ColumnWidth = newCW: .EntireRow.autofit
                    rh = .EntireRow.RowHeight: If rh > maxRH Then maxRH = rh
                    .Merge: .Columns(1).ColumnWidth = cw
                End With
                Exit For ' Поскольку нам нужна лишь одна ячейка, то в целях оптимизации прервем цикл
            End If
        Next cell
        If maxRH > 0 Then ro.EntireRow.RowHeight = maxRH
    Next ro
End Sub

Алгоритм реализован. Один нюанс с коэффициентом 1.66 — это важная деталь. Поскольку у каждой ячейки Excel есть еще и границы, то мы полученную длину умножим на этот коэффициент, что бы получить полноценную длину, соизмеримую с длиной ячейки объединенной области.

Autofit

В этой части все просто. Делаем цикл по всем строкам с данными таблицы и вызываем AutoFitMergedCellRowHeight для каждой строки. Для оптимизации мы будем еще передавать ширину столбца с текстом, которую посчитаем при первом вызове. А вместо всей строки будем передавать только область объединенных ячеек. Такой подход заточен под жесткий шаблон и только одно поле с текстом.

Sub autofit()
    Dim row As Integer
    Dim cellWidth As Double
    Dim startRangeCell As Integer
    Dim endRangeCell As Integer
    Dim startRaw As Integer
 
    startRangeCell = 8
    endRangeCell = 32
    startRaw = 46
    cellWidth = 0
    For row = startRaw To ActiveWorkbook.Worksheets(1).UsedRange.Rows.count
        If ActiveWorkbook.Worksheets.Application.Cells(row, 1).Text = "f" Then
            Exit For
        End If
        If ActiveWorkbook.Worksheets.Application.Cells(row, 1).Text = "l" Then
            If ActiveWorkbook.Worksheets.Application.Cells(row, 8).Text <> "" Then
                AutoFitMergedCellRowHeight ActiveWorkbook.ActiveSheet.Range(Cells(row, startRangeCell), Cells(row, endRangeCell)), cellWidth
            End If
        End If
    Next row
 
End Sub