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

[tae1980]

Возвращаюсь к ранее обсуждаемой теме.
Не много покопавшись в литературе нашел один макрос, который немного адаптировал под свои нужды. Его работа, хотя и не без замечаний, но вполне устраивает. Данный макрос подбирает размер только для текущей ячейке...
Нужно подбирать размер для всех объединенных на листе ячеек, или для все строки (а потом построчно провести обработку всего листа).
Что-то не соображу с какой стороны подойти к задаче... :((

[EducatedFool]

Методом научного тыка сотворил такой вариант:

Sub AutoFitMergedCellRowHeight(ByRef ra As Range)
    Dim CurrCell As Range, cell As Range, ma As Range: Dim col As Range, ro As Range
    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
                    For Each col In .EntireColumn: newCW = newCW + col.ColumnWidth: Next
                    .Columns(1).ColumnWidth = newCW: .EntireRow.AutoFit
                    rh = .EntireRow.RowHeight: If rh > maxRH Then maxRH = rh
                    .Merge: .Columns(1).ColumnWidth = cw
                End With
            End If
        Next cell
        If maxRH > 0 Then ro.EntireRow.RowHeight = maxRH
    Next ro
End Sub

Sub ПримерИспользования()
    Application.ScreenUpdating = False
    AutoFitMergedCellRowHeight [a2:z8]
End Sub

Проверяй, может подойдёт...

(добавлено)
Этот, и ещё один вариант кода, выложил на сайте: http://excelvba.ru/code/AutoFitMergedCells

[tae1980]

Просто замечательно! Работает без нареканий. Не скажу за других, а у меня решилась одна из главных проблем в экселе.
Теперь осталось разобраться собственно как оно работает.


При горизонтальном объединение все просто замечательно. А вот если еще есть и вертикальное объединение, обработка не происходит, по крайней мере результата не видно. Попробую разобраться....

Вернее не так. Неверное форматирование происходит в случае если в начале строки стоит ячейка с вертикальным объединением, а после нее в той же строке идет ячейка без вертикального объединения.
Пример прилагается. ИМХО поймать это можно, но сложно, так как вариации объединения строк могут мыть самые разные. Скорее всего целесообразно оставить как есть.
Единственное простое решения, чтобы при автофильтре ни когда не происходило уменьшение высоты ячейки (только увеличение). А перед обработкой приводить все строки к единичной высоте.



В процессе работы выяснилось еще одно обстоятельство, связанное с размером ячеек. Имеем 8 колонок объединенных шириной =2 (2*8=16). И текст который занимает в них 3 строчки. Создаем одну колонку шириною 16 и размещаем в ней тот же текст, он уже занимает 6 строчек и сама колонка на взгляд выглядит уже. В ручную раздвигаем колонку так что бы текст уместился в 3 строчках, получаем ширину 21 (разница в 5). Скорее есть некие отступы от края ячейки для текста или для границ, который в случае объединения ячеек пропадают. Они та и должны давать такую разницу. Что приводит к ошибочному определению высоты ячейки.
Вопрос: каковы размеры этих отступов? Можно ли принять такую формулу расчета поправочного коэффициента: (21-16)/8=0,625 ?

[tae1980]

Экспериментально установлен размер поправки на каждую объединенную ячейку 0,64.
Вот что у меня получилось:

Sub AutoFitMergedCellRowHeight(ByRef ra As Range)
    Dim CurrCell As Range, cell As Range, ma As Range: Dim col As Range, ro As Range
    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: newRH = 1: cColumn = 0
                With ma
                    cw = .Columns(1).ColumnWidth: .UnMerge
                    For Each col In .EntireColumn: newCW = newCW + col.ColumnWidth: cColumn = cColumn + 1: Next
                    For Each col In .EntireRow: newRH = IIf(newRH = 1, 0, newRH + col.RowHeight): Next
                    .Columns(1).ColumnWidth = newCW + (cColumn * 0.64): .EntireRow.AutoFit
                    rh = .Cells(1).RowHeight - newRH
                    If rh > maxRH Then maxRH = rh
                    .Merge: .Columns(1).ColumnWidth = cw
                End With
            End If
        Next cell
        If maxRH > 0 Then ro.EntireRow.RowHeight = maxRH
    Next ro
End Sub

Sub ПримерИспользования()
    Application.ScreenUpdating = False
    AutoFitMergedCellRowHeight Range([A1], [AG5])
End Sub

Еще вопрос: у меня ширина всех таблиц [A:AG], а вот длина у всех разная начиная с первой строки. Как правильно указать диапазон для макроса, для обработки все таблицы? Я могу узнать долину таблицы в строках, нужно ли это?

[EducatedFool]

Как правильно указать диапазон для макроса, для обработки все таблицы? Я могу узнать долину таблицы в строках, нужно ли это?

Не увидев таблицы, сложно сказать, как определить её длину.
Особенно, если присутствуют несколько таблиц одна над другой.

Попробуйте заменить [a2:z8] на activesheet.usedrange

А вот если еще есть и вертикальное объединение, обработка не происходит, по крайней мере результата не видно.

Знаю про это Точнее, что-то происходит, но не совсем то, что нужно.
Я очень надеялся, что у тебя в файле нет таких ячеек, поскольку, если в макросе учитывать все возможные варианты группировки ячеек, и рассматривать случаи, когда в одной строке присутствуют объединённые ячейки размером 1*5, 2*5, 3*1, 4*6 и т.д., код получается очень большим (да и отлаживать его очень долго)

так как вариации объединения строк могут быть самые разные

Вот это точно подмечено...
В некоторых случаях даже не совсем понятен алгоритм подбора высоты и ширины - ибо при большом количестве пристыкованных друг к другу объединённых ячеек различных размеров может получиться так, что подбор высоты одной ячейки влияет на несколько предыдущих ячеек, и т.д.

Скорее есть некие отступы от края ячейки для текста или для границ, который в случае объединения ячеек пропадают.

Тоже заметил такое, когда экспериментировал с макросом.
Честно говоря, даже не хочется заморачиваться с этим вопросом - на написание универсального макроса уйдёт очень много времени, а польза от его применения весьма сомнительна.

В самом деле, зачем тебе нужен этот макрос?
Неужели нельзя один раз выставить нужные размеры для строк и столбцов?
Приведи пример файла, в котором надо обязательно делать это программно.
Заодно, возможно, найдутся другие варианты решения проблемы.

[tae1980]

Сообщение от EducatedFool

Не увидев таблицы, сложно сказать, как определить её длину.
Особенно, если присутствуют несколько таблиц одна над другой.
Попробуйте заменить [a2:z8] на activesheet.usedrange

Прикладываю пример таблицы с новой версией процедуры.

Вот это точно подмечено...
В некоторых случаях даже не совсем понятен алгоритм подбора высоты и ширины - ибо при большом количестве пристыкованных друг к другу объединённых ячеек различных размеров может получиться так, что подбор высоты одной ячейки влияет на несколько предыдущих ячеек, и т.д.

Вроде удалось решить эту проблему, при этом весьма простыми средствами. Чему я был сильно удивлен. :)

Тоже заметил такое, когда экспериментировал с макросом.
Честно говоря, даже не хочется заморачиваться с этим вопросом - на написание универсального макроса уйдёт очень много времени, а польза от его применения весьма сомнительна.

Подобные проблемы всегда решались с использованием поправок. Посмотри как работает новая версия функции. В ней так же малыми средствами удалось ускорить работу на ~25-30%. Для дальнейшего ускорения скорее всего придется свернуть макрос в dll.

В самом деле, зачем тебе нужен этот макрос?
Неужели нельзя один раз выставить нужные размеры для строк и столбцов?
Приведи пример файла, в котором надо обязательно делать это программно.
Заодно, возможно, найдутся другие варианты решения проблемы.

Пример прилагается. На счет не нужности, не согласен. Это одно из самых узких мест в экселе, скажем в опен офис такой проблемы нету. При работе в экселе как с эл. таблицей в общем особых проблем нет, хотя и приходится не много гемороиться. А вот если использовать ексель как базу для формирования документов, особенно сложного оформления, проблема встает ребром. Мне приходилось резервировать по 10 и более строк на ячейки таблицы, что быть обеспечить влизания хотя бы 90% возможных текстовых заполнений, при этом отлавливание оставшихся 10% ложилось на плечи оператора. Что самое смешное почти всегда текст в данной ячейке занимал 1-2 строчки...
В общем пример в файле, если появятся предложения, будет интересно услышать.

[tae1980]

Новая версия:

Sub AutoFitMergedCellRowHeight(ByRef ra As Range)
    Dim CurrCell As Range, cell As Range, ma As Range: Dim col As Range, ro As Range
    For Each ro In ra.Rows
        maxRH = 0
        For n = 1 To ro.Cells.Count
            With ro.Cells(n)
                If .MergeCells Then
                    If .Address = .MergeArea.Cells(1).Address Then
                        Debug.Print .Address
                        Set ma = .MergeArea: newCW = 0: newRH = 1
                        With ma
                            cw = .Columns(1).ColumnWidth: .UnMerge
                            For Each col In .EntireColumn: newCW = newCW + col.ColumnWidth + 0.64: Next
                            For Each col In .EntireRow: newRH = IIf(newRH = 1, 0, newRH + col.RowHeight): Next
                            .Columns(1).ColumnWidth = newCW: .EntireRow.AutoFit
                            rh = .Cells(1).RowHeight - newRH
                            If rh > maxRH Then maxRH = rh
                            .Merge: .Columns(1).ColumnWidth = cw
                        End With
                    End If
                    n = n + .MergeArea.Cells.Columns.Count - 1
                End If
            End With
        Next n
        If maxRH > 0 Then ro.EntireRow.RowHeight = maxRH
    Next ro
End Sub

Sub ПримерИспользования()
    Application.ScreenUpdating = False
    AutoFitMergedCellRowHeight ActiveSheet.UsedRange
End Sub

[Eresiarh]

При нажатии на кнопку, сохраняется книга, она тут же открывается и для всей книги используется этот макрос.
1. Как это правильно написать?

Private Sub CommandButton1_Click()
ChDir "C:\"
ThisWorkbook.SaveCopyAs Filename:=Worksheets("...").Range("...") + " ..." + ".xls"
Workbooks.Open "C:\" + Worksheets("...").Range("...") + " ..." + ".xls"
AutoFitMergedCellRowHeight ActiveWorkbook.Sheets

ну и как наглядно видно, я не знаю как правильно здесь обращаться. Подскажите пожайлуста.

2. Если вас не затруднит, посоветуйте самоучитель по VBA Excel.

[Eresiarh]

Целый день убил, собрал все возможные ошибки... А даже на тему "как макрос передалать в код" только про Access есть. Как это сделать??? Как правильно сказать параметру "ra" всю книгу, а не активный лист?

[Eresiarh]

Sub AutoFitMergedCellRowHeight(ByRef ra As Range)
    Dim CurrCell As Range, cell As Range, ma As Range: Dim col As Range, ro As Range
    For Each ro In ra.Rows
        maxRH = 0
        For n = 1 To ro.Cells.Count
            With ro.Cells(n)
                If .MergeCells Then
                    If .Address = .MergeArea.Cells(1).Address Then
                        Debug.Print .Address
                        Set ma = .MergeArea: newCW = 0: newRH = 1
                        With ma
                            cw = .Columns(1).ColumnWidth: .UnMerge
                            For Each col In .EntireColumn: newCW = newCW + col.ColumnWidth + 0.64: Next
                            For Each col In .EntireRow: newRH = IIf(newRH = 1, 0, newRH + col.RowHeight): Next
                            .Columns(1).ColumnWidth = newCW: .EntireRow.AutoFit
                            rh = .Cells(1).RowHeight - newRH
                            If rh > maxRH Then maxRH = rh
                            .Merge: .Columns(1).ColumnWidth = cw
                        End With
                    End If
                    n = n + .MergeArea.Cells.Columns.Count - 1
                End If
            End With
        Next n
        If maxRH > 0 Then ro.EntireRow.RowHeight = maxRH
    Next ro
End Sub

Лучший и единственный макрос в Интернет, который делает автоподбор высоты.
Но суть в том, что ввиду не знания языка VBA я не могу заставить его пробежаться по всем листам, так как ra не дает мне это сделать, пишет про не совместимость типов и т.д.. Раз у меня получилось, но копии не осталось. Сейчас забыл как делал, а если брать каждый лист по очереди то макрос выполняется так долго, что жуть.

Подскажите где читать.
Либо как это написать.