Мини-курс "5 чудес Excel"
Автоподбор высоты объединённой ячейки
Автоподбор высоты строки, в которой есть объединённая ячейка, не работает. И чаще всего Вы вручную настраиваете высоту таких строк. Никакой экспертной работы и развития, одна рутина...
PowerQuery тут тоже не поможет. А вот макрос – он как всемогущий Джинн :)
Я сделала своим макросом вот что:
1 - В копии листа убрала объединённую ячейку и изменила ширину столбца с записями на равную сумме ширин всех исходных столбцов объединённой ячейки.
2 - Выполнила автоподбор штатной командой, никаких расчётов – всё будет так, как сделает сам Excel!
3 - Получившуюся высоту строку устанавливаю для строки-оригинала. Идеально!
Должна, конечно, предупредить, что остаётся ошибка, когда даже при ручном автоподборе высота строки может получиться несколько больше, чем нужно (вверху образуется пустота), но это внутренняя ошибка Excel и с ней я ничего не могу сделать.
PowerQuery тут тоже не поможет. А вот макрос – он как всемогущий Джинн :)
Я сделала своим макросом вот что:
1 - В копии листа убрала объединённую ячейку и изменила ширину столбца с записями на равную сумме ширин всех исходных столбцов объединённой ячейки.
2 - Выполнила автоподбор штатной командой, никаких расчётов – всё будет так, как сделает сам Excel!
3 - Получившуюся высоту строку устанавливаю для строки-оригинала. Идеально!
Должна, конечно, предупредить, что остаётся ошибка, когда даже при ручном автоподборе высота строки может получиться несколько больше, чем нужно (вверху образуется пустота), но это внутренняя ошибка Excel и с ней я ничего не могу сделать.
Обычно в таком случае я делаю немного шире исходные столбцы и запускаю макрос ещё раз. Чаще всего это решает проблему.
Файл с моим макросом скачайте внизу страницы. Обратите внимание, что при открытии файла макросы нужно включить (внутри есть скрин-подсказка) и что для автоподбора нужно выделить ЯЧЕЙКИ, НЕ СТРОКИ, это важно.
Скопируйте в свой файл код макроса - весь выделенный цветом текст
Sub AutofitRowHeightWithMerge()
'макрос работает по заранее выделенному диапазону ЯЧЕЕК, НЕ СТРОК
'макрос работает по заранее выделенному диапазону ЯЧЕЕК, НЕ СТРОК
Application.DisplayAlerts = False
Selection.WrapText = True 'включить перенос текста в ячейках
'запомнить текущий лист
Set sh1 = ActiveWorkbook.ActiveSheet
'Сделать копию листа
ActiveSheet.Copy: Set Sh2 = ActiveWorkbook.ActiveSheet
nc = Selection.Columns.Count 'кол-во столбцов в выделении
nc1 = Selection.Column 'номер первого столбца в выделении
nc2 = nc1 + nc - 1 'номер последнего столбца в выделении
nr = Selection.Rows.Count 'кол-во строк в выделении
nr1 = Selection.Row 'номер первой строки в выделении
nr2 = nr1 + nr - 1 'номер последней строки в выделении
'сумма ширин всех столбцов в выделении
For i = nc1 To nc2
wc = wc + Columns(i).ColumnWidth
Next
'Debug.Print wc
Selection.UnMerge 'отменить объединённые ячейки
Columns(nc1).ColumnWidth = wc
If wc > 254.86 Then
MsgBox "Слишком много столбцов! Общая ширина выделения должна быть не более 254,86!", vbCritical
Application.DisplayAlerts = True
Exit Sub
End If
For i = nr1 To nr2
Rows(i).AutoFit 'автоподбор высоты строки
rh = Rows(i).RowHeight 'записать получившуюся высоту строки
'если ниже пусто, считать кол-во пустых строк
Do While Cells(i + 1 + q, nc1) = "" And i + 1 + q <= nr2
q = q + 1
Loop
If q = 0 Then
rh = rh
Else: rh = rh / (1 + q) '(разделить высоту на получившееся число строк)
End If
If rh > 409 Then
MsgBox "Получается слишком большая высота строки! Я умею настраивать максимум 409!", vbCritical
Application.DisplayAlerts = True
Exit Sub
End If
sh1.Rows(i).Resize(1 + q).RowHeight = rh
i = i + q 'пересчёт номера i
q = 0 'очистка переменной
Next i
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Selection.WrapText = True 'включить перенос текста в ячейках
'запомнить текущий лист
Set sh1 = ActiveWorkbook.ActiveSheet
'Сделать копию листа
ActiveSheet.Copy: Set Sh2 = ActiveWorkbook.ActiveSheet
nc = Selection.Columns.Count 'кол-во столбцов в выделении
nc1 = Selection.Column 'номер первого столбца в выделении
nc2 = nc1 + nc - 1 'номер последнего столбца в выделении
nr = Selection.Rows.Count 'кол-во строк в выделении
nr1 = Selection.Row 'номер первой строки в выделении
nr2 = nr1 + nr - 1 'номер последней строки в выделении
'сумма ширин всех столбцов в выделении
For i = nc1 To nc2
wc = wc + Columns(i).ColumnWidth
Next
'Debug.Print wc
Selection.UnMerge 'отменить объединённые ячейки
Columns(nc1).ColumnWidth = wc
If wc > 254.86 Then
MsgBox "Слишком много столбцов! Общая ширина выделения должна быть не более 254,86!", vbCritical
Application.DisplayAlerts = True
Exit Sub
End If
For i = nr1 To nr2
Rows(i).AutoFit 'автоподбор высоты строки
rh = Rows(i).RowHeight 'записать получившуюся высоту строки
'если ниже пусто, считать кол-во пустых строк
Do While Cells(i + 1 + q, nc1) = "" And i + 1 + q <= nr2
q = q + 1
Loop
If q = 0 Then
rh = rh
Else: rh = rh / (1 + q) '(разделить высоту на получившееся число строк)
End If
If rh > 409 Then
MsgBox "Получается слишком большая высота строки! Я умею настраивать максимум 409!", vbCritical
Application.DisplayAlerts = True
Exit Sub
End If
sh1.Rows(i).Resize(1 + q).RowHeight = rh
i = i + q 'пересчёт номера i
q = 0 'очистка переменной
Next i
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Как вставить этот код в свой файл, я показываю на тематическом уроке Макрос напрокат. Вы можете посмотреть его запись: https://excelforum.autoweboffice.ru/?r=ordering/cart/as1&id=49&clean=true&lg=ru