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

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

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

Андрей:

Здравствуйте!
Дмитрий, ниже модернизированный код с комментариями и, если сочтёте нужным, просьба заменить мой предыдущий вариант.
'------------------------------------------------------------------------------------------------------------------
'Функция принимает:
'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