Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Автоподбор высоты объединенных ек для фиксированных столбцов - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Автоподбор высоты объединенных ек для фиксированных столбцов (Макросы/Sub)
Автоподбор высоты объединенных ек для фиксированных столбцов
albertikhsanov00 Дата: Понедельник, 07.11.2022, 09:54 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 20% ±

Здравствуйте. Имеется вот такой код автоподбора высоты объединенных ячеек для выбранного диапазона
[vba]
Код
Sub MergeCell_AutoHeight() ' автоподбор высоты объединенных ячеек в
Selection
If Intersect(ActiveWindow.RangeSelection, ActiveSheet.UsedRange) Is
Nothing Then Exit Sub
Application.ScreenUpdating = False
Dim rCell As Range, rMergeArea As Range, rColumn As Range, rRow As Range
Dim maxRowHeight!, newCellWidth!, CellWidth!, RowHeight!
For Each rRow In Intersect(ActiveWindow.RangeSelection,
ActiveSheet.UsedRange).Rows ' цикл по всем строкам диапазона
​ ​ ​ ​ maxRowHeight = 0
​ ​ ​ ​ For Each rCell In rRow.Cells ' цикл по всем ячейкам строки
​ ​ ​ ​ ​ ​ ​ ​ If rCell.MergeCells And rCell.Address =
rCell.MergeArea.Cells(1).Address Then ' если это первая ячейкам
объединенной области
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ Set rMergeArea = rCell.MergeArea: newCellWidth = 0
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ With rMergeArea
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ CellWidth = .Columns(1).ColumnWidth ' запомним ширину
первого столбца в объединенной области
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ .UnMerge ' разгруппировываем область
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ For Each rColumn In .EntireColumn: newCellWidth = newCellWidth
+ rColumn.ColumnWidth: Next
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ .Columns(1).ColumnWidth = newCellWidth ' делаем ширину
первой ячейки такую же, как была у всей объединенной области
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ .EntireRow.AutoFit ' автоподбор высоты первой ячейки
объединенной области
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ RowHeight = .Item(1).RowHeight ' запомнить подобранную
высоту для этой объединенной области
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ 'RowHeight = .EntireRow.RowHeight ' запомнить подобранную
высоту для этой объединенной области
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ If RowHeight > maxRowHeight Then maxRowHeight = RowHeight '
если подобранная высота для этой объединенной области
максимальна в строке, то запомним её
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ .Merge ' группируем область обратно
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ .Columns(1).ColumnWidth = CellWidth ' восстановим ширину
первого столбца
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ End With
​ ​ ​ ​ ​ ​ ​ ​ End If
​ ​ ​ ​ Next rCell ' повторяем со следующей ячейкой строки
​ ​ ​ ​ If maxRowHeight > 0 Then rRow.EntireRow.RowHeight = maxRowHeight '
устанавливаем подобранную максимальную высоту строки
Next rRow ' переходим к следующей строке
Application.ScreenUpdating = True
End Sub
[/vba]
А хотелось бы чтобы он был не для выбранного диапазона, а для фиксированных столбцов и делал до конца пока текст не закончится. Файл прикрепил, там я более подробно расписал. Заранее спасибо!!!
К сообщению приложен файл: -707353123.xlsm(58.3 Kb)
 
Ответить
СообщениеЗдравствуйте. Имеется вот такой код автоподбора высоты объединенных ячеек для выбранного диапазона
[vba]
Код
Sub MergeCell_AutoHeight() ' автоподбор высоты объединенных ячеек в
Selection
If Intersect(ActiveWindow.RangeSelection, ActiveSheet.UsedRange) Is
Nothing Then Exit Sub
Application.ScreenUpdating = False
Dim rCell As Range, rMergeArea As Range, rColumn As Range, rRow As Range
Dim maxRowHeight!, newCellWidth!, CellWidth!, RowHeight!
For Each rRow In Intersect(ActiveWindow.RangeSelection,
ActiveSheet.UsedRange).Rows ' цикл по всем строкам диапазона
​ ​ ​ ​ maxRowHeight = 0
​ ​ ​ ​ For Each rCell In rRow.Cells ' цикл по всем ячейкам строки
​ ​ ​ ​ ​ ​ ​ ​ If rCell.MergeCells And rCell.Address =
rCell.MergeArea.Cells(1).Address Then ' если это первая ячейкам
объединенной области
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ Set rMergeArea = rCell.MergeArea: newCellWidth = 0
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ With rMergeArea
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ CellWidth = .Columns(1).ColumnWidth ' запомним ширину
первого столбца в объединенной области
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ .UnMerge ' разгруппировываем область
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ For Each rColumn In .EntireColumn: newCellWidth = newCellWidth
+ rColumn.ColumnWidth: Next
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ .Columns(1).ColumnWidth = newCellWidth ' делаем ширину
первой ячейки такую же, как была у всей объединенной области
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ .EntireRow.AutoFit ' автоподбор высоты первой ячейки
объединенной области
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ RowHeight = .Item(1).RowHeight ' запомнить подобранную
высоту для этой объединенной области
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ 'RowHeight = .EntireRow.RowHeight ' запомнить подобранную
высоту для этой объединенной области
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ If RowHeight > maxRowHeight Then maxRowHeight = RowHeight '
если подобранная высота для этой объединенной области
максимальна в строке, то запомним её
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ .Merge ' группируем область обратно
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ .Columns(1).ColumnWidth = CellWidth ' восстановим ширину
первого столбца
​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ ​ End With
​ ​ ​ ​ ​ ​ ​ ​ End If
​ ​ ​ ​ Next rCell ' повторяем со следующей ячейкой строки
​ ​ ​ ​ If maxRowHeight > 0 Then rRow.EntireRow.RowHeight = maxRowHeight '
устанавливаем подобранную максимальную высоту строки
Next rRow ' переходим к следующей строке
Application.ScreenUpdating = True
End Sub
[/vba]
А хотелось бы чтобы он был не для выбранного диапазона, а для фиксированных столбцов и делал до конца пока текст не закончится. Файл прикрепил, там я более подробно расписал. Заранее спасибо!!!

Автор - albertikhsanov00
Дата добавления - 07.11.2022 в 09:54
andreimurysev Дата: Вторник, 08.11.2022, 12:30 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 21
Репутация: 5 ±
Замечаний: 0% ±

albertikhsanov00, если актуально, смотрите файл
К сообщению приложен файл: -707353123-1-.xlsm(58.0 Kb)
 
Ответить
Сообщениеalbertikhsanov00, если актуально, смотрите файл

Автор - andreimurysev
Дата добавления - 08.11.2022 в 12:30
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Автоподбор высоты объединенных ек для фиксированных столбцов (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2022 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!