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

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

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

В 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