Высота строки в excel программно

Хитрости »

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

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

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

{quote}{login=Ан13}{date=26.06.2008 02:24}{thema=Как изменить высоту строки в VB}{post}Ответьте пожалуйста на мой вопрос!!!{/post}{/quote}  

  Смотрите код.  

  Sub RowHeightFiting3()  
‘ Объединённая ячейка должна быть активной!!!  
‘ Если требуется подобрать высоту для неактивной ячейки, то нужно переменной MyRanAdr присвоить ПОЛНЫЙ адрес области объединённой ячейки ‘(Напр, MyRanAdr = «D4:G7» вместо строки MyRanAdr = ActiveCell.MergeArea.Address)  
Application.ScreenUpdating = False  

  Dim MyNormalMiddleWidth, MyNormalEdgeWidth  
Dim c1, c2, w1, w2 ‘временные переменные ширин столбцов в симв и пт  
Dim MyTempCell As Range  
Dim OldColWidth  
Set MyTempCell = Cells(65536, 256)  
OldColWidth = MyTempCell.ColumnWidth  
c1 = 10 ‘ ширину в симв можно установить любую, но точно не менее 1 (где нельзя реально определить нужные нам данные),  
c2 = 15 ‘ и лучше более 3 и целочисленные (для уменьшения влияния ошибки округления….. впрочем, в коде эта возможная ошибка учитывается)  
MyTempCell.ColumnWidth = c1  
c1 = MyTempCell.ColumnWidth  
w1 = MyTempCell.Width  
MyTempCell.ColumnWidth = c2  
c2 = MyTempCell.ColumnWidth  
w2 = MyTempCell.Width  
MyNormalMiddleWidth = Format((w2 — w1) / (c2 — c1), «#0.00»)  
MyNormalEdgeWidth = Format((c2 * w1 — c1 * w2) / (c2 — c1), «#0.00»)  
MyTempCell.ColumnWidth = OldColWidth  
Dim MyRanAdr As String  
Dim MergeAreaTotalHeight, NewRH  
Dim MergeAreaFirstCellColWidth, MergeAreaFirstCellColHeight  
MyRanAdr = ActiveCell.MergeArea.Address ‘адрес области с объединённой ячейкой  
MergeAreaTotalHeight = Range(MyRanAdr).Height ‘ высота всей объединённой ячейки в ед. пт  
MergeAreaFirstCellColWidth = Range(MyRanAdr).Cells(1, 1).EntireColumn.ColumnWidth ‘ ширина первого столбца в объединённой ячейке  
MergeAreaFirstCellColHeight = Range(MyRanAdr).Cells(1, 1).EntireRow.RowHeight ‘ высота первой строки в объединённой ячейке  
Range(MyRanAdr).Cells(1, 1).ColumnWidth = (Range(MyRanAdr).Width — MyNormalEdgeWidth) / MyNormalMiddleWidth ‘установка ширины первого столбца объед. ячейки равной общей ширине объед. ячейки »’БЕЗ ПОДГОНКИ!!!  
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).EntireColumn.ColumnWidth = MergeAreaFirstCellColWidth  
If NewRH < MergeAreaTotalHeight Then ‘если новая высота меньше изначальной, то оставляем изначальную высоту!  
Range(MyRanAdr).Cells(1, 1).EntireRow.RowHeight = MergeAreaFirstCellColHeight  
Else  
Range(MyRanAdr).Cells(1, 1).EntireRow.RowHeight = NewRH — (MergeAreaTotalHeight — MergeAreaFirstCellColHeight) ‘ для 1st строки в объед.ячейке  
End If  
‘Range(MyRanAdr).EntireRow.RowHeight = NewRH / Range(MyRanAdr).Rows.Count ‘для равной высоты всех строк в объед.ячейке (вместо предыдущего блока If)  
Application.ScreenUpdating = True  
End Sub