Совет. Другие языки - Google-Translated. Вы можете посетить English версия этой ссылки.
Войти
x
or
x
x
Регистрация
x

or

Как автоматически установить высоту строки объединенных ячеек в Excel?

В Excel мы можем быстро настроить высоту строки в соответствии с содержимым ячейки, используя Автоподбор высоты строки но эта функция полностью игнорирует объединенные ячейки. То есть вы не можете применить Автоподбор высоты строки чтобы изменить высоту строки объединенных ячеек, вам необходимо вручную настроить высоту строки для объединенных ячеек один за другим. В этой статье я могу привести некоторые быстрые методы для решения этой проблемы.

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

Вкладка «Office» Включите редактирование и просмотр с вкладками в Office и упростите свою работу ...
Kutools для Excel - лучший инструмент для работы в офисе, который решит большинство ваших проблем с Excel
  • Повторно использовать что-либо: Добавьте наиболее часто используемые или сложные формулы, диаграммы и все остальное в избранное и быстро используйте их в будущем.
  • Больше, чем текстовые функции 20: Извлечь номер из текстовой строки; Извлечь или удалить часть текстов; Преобразование чисел и валют в английские слова ...
  • Инструменты слияния: Несколько рабочих книг и листов в одном; Объединить несколько ячеек / строк / столбцов без потери данных; Объединить повторяющиеся строки и суммы ...
  • Сплит Инструменты: Разбить данные на несколько листов на основе значения; Одна рабочая книга для нескольких файлов Excel, PDF или CSV; От одного столбца до нескольких столбцов ...
  • Вставить Пропуск Скрытые / отфильтрованные строки; Подсчет и сумма по цвету фона; Создать список рассылки и Отправка писем по значению ячейки...
  • Суперфильтр: Создавайте расширенные схемы фильтров и применяйте их к любым листам; Сортировать по неделям, дням, частоте и более; Фильтр жирным шрифтом, формулами, комментариями ...
  • Более чем мощные функции 300; Работает с Office 2007-2019 и 365; Поддерживает все языки; Простота развертывания в компании; Полнофункциональная 60-дневная бесплатная пробная версия.

arrow синий правый пузырь Автоматическая установка высоты строки объединенных ячеек с кодом VBA


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

док-Автоподбор-слившаяся-клетка-1

1, Удерживайте ALT + F11 и открывает Окно Microsoft Visual Basic для приложений.

2. Щелчок Вставить > модуль, и вставьте следующий код в Окно модуля.

Код VBA: автоматическая установка высоты строки нескольких объединенных ячеек
Option Explicit
Public Sub AutoFitAll()
  Call AutoFitMergedCells(Range("a1:b2"))
   Call AutoFitMergedCells(Range("c4:d6"))
    Call AutoFitMergedCells(Range("e1:e3"))
End Sub
Public Sub AutoFitMergedCells(oRange As Range)
  Dim tHeight As Integer
  Dim iPtr As Integer
  Dim oldWidth As Single
  Dim oldZZWidth As Single
  Dim newWidth As Single
  Dim newHeight As Single
  With Sheets("Sheet4")
    oldWidth = 0
    For iPtr = 1 To oRange.Columns.Count
      oldWidth = oldWidth + .Cells(1, oRange.Column + iPtr - 1).ColumnWidth
    Next iPtr
    oldWidth = .Cells(1, oRange.Column).ColumnWidth + .Cells(1, oRange.Column + 1).ColumnWidth
    oRange.MergeCells = False
    newWidth = Len(.Cells(oRange.Row, oRange.Column).Value)
    oldZZWidth = .Range("ZZ1").ColumnWidth
    .Range("ZZ1") = Left(.Cells(oRange.Row, oRange.Column).Value, newWidth)
    .Range("ZZ1").WrapText = True
    .Columns("ZZ").ColumnWidth = oldWidth
    .Rows("1").EntireRow.AutoFit
    newHeight = .Rows("1").RowHeight / oRange.Rows.Count
    .Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).RowHeight = newHeight
    oRange.MergeCells = True
    oRange.WrapText = True
    .Range("ZZ1").ClearContents
    .Range("ZZ1").ColumnWidth = oldZZWidth
  End With
End Sub

Заметки:

(1.) В приведенном выше коде вы можете добавлять новые диапазоны только для копирования Вызов AutoFitMergedCells (диапазон ("a1: b2")) сценарий много раз, как вы хотите, и измените диапазоны объединенных ячеек на нужные вам.

(2.) И вы должны изменить текущее имя рабочего листа Sheet4 к используемому имени листа.

3, Затем нажмите F5 для запуска этого кода, и теперь вы можете видеть, что все объединенные ячейки были автоматически установлены на их содержимое ячейки, см. снимок экрана:

док-Автоподбор-слившаяся-клетка-1


Связанная статья:

Как автоматически установить ширину столбца в Excel?


Kutools для Excel - лучший инструмент для повышения производительности в офисе Повысьте производительность на 80%

  • Снова использовать: Быстро вставить сложные формулы, графики и все, что вы использовали раньше; Шифрование ячеек с паролем; Создать список рассылки и отправлять электронные письма ...
  • Супер Формула Бар (легко редактировать несколько строк текста и формул); Макет чтения (легко читать и редактировать большое количество ячеек); Вставить в отфильтрованный диапазон...
  • Объединить ячейки / строки / столбцы без потери данных; Содержание сплит-клеток; Объединить дублирующиеся строки / столбцы... предотвратить повторяющиеся клетки; Сравнить диапазоны...
  • Выберите Дубликат или Уникальный Ряды; Выберите пустые строки (все ячейки пусты); Супер найти и нечеткая находка во многих рабочих тетрадях; Случайный выбор ...
  • Точная копия Несколько ячеек без изменения формулы ссылки; Автоматическое создание ссылок на несколько листов; Вставить пули, Флажки и многое другое ...
  • Извлечение текстаДобавить текст, Удалить по позиции, Удалить пространство; Создание и печать промежуточных итогов подкачки; Преобразование содержимого ячеек и комментариев...
  • Суперфильтр (сохранить и применить схемы фильтров к другим листам); Расширенный поиск по месяцам / неделям / дням, частоте и более; Специальный фильтр жирным шрифтом, курсивом ...
  • Объединить рабочие тетради и рабочие листы; Объединение таблиц на основе ключевых столбцов; Разделить данные на несколько листов; Пакетное преобразование xls, xlsx и PDF...
  • Более чем мощные функции 300, Поддерживает Office / Excel 2007-2019 и 365. Поддерживает все языки. Простота развертывания на вашем предприятии или в организации. Полнофункциональная 60-дневная бесплатная пробная версия.
вкладка kte 201905

Вкладка «Office» предоставляет интерфейс с вкладками для Office и упрощает работу

  • Включить редактирование и чтение с вкладками в Word, Excel, PowerPoint, Издатель, Доступ, Visio и Проект.
  • Открывайте и создавайте несколько документов в новых вкладках одного и того же окна, а не в новых окнах.
  • Увеличивает вашу производительность на 50% и уменьшает сотни щелчков мышью для вас каждый день!
нижняя часть офиса

<p >


Kutools для Excel - лучший инструмент для повышения производительности в офисе Повысьте производительность на 80%

  • Снова использовать: Быстро вставить сложные формулы, графики и все, что вы использовали раньше; Шифрование ячеек с паролем; Создать список рассылки и отправлять электронные письма ...
  • Супер Формула Бар (легко редактировать несколько строк текста и формул); Макет чтения (легко читать и редактировать большое количество ячеек); Вставить в отфильтрованный диапазон...
  • Объединить ячейки / строки / столбцы без потери данных; Содержание сплит-клеток; Объединить дублирующиеся строки / столбцы... предотвратить повторяющиеся клетки; Сравнить диапазоны...
  • Выберите Дубликат или Уникальный Ряды; Выберите пустые строки (все ячейки пусты); Супер найти и нечеткая находка во многих рабочих тетрадях; Случайный выбор ...
  • Точная копия Несколько ячеек без изменения формулы ссылки; Автоматическое создание ссылок на несколько листов; Вставить пули, Флажки и многое другое ...
  • Извлечение текстаДобавить текст, Удалить по позиции, Удалить пространство; Создание и печать промежуточных итогов подкачки; Преобразование содержимого ячеек и комментариев...
  • Суперфильтр (сохранить и применить схемы фильтров к другим листам); Расширенный поиск по месяцам / неделям / дням, частоте и более; Специальный фильтр жирным шрифтом, курсивом ...
  • Объединить рабочие тетради и рабочие листы; Объединение таблиц на основе ключевых столбцов; Разделить данные на несколько листов; Пакетное преобразование xls, xlsx и PDF...
  • Более чем мощные функции 300, Поддерживает Office / Excel 2007-2019 и 365. Поддерживает все языки. Простота развертывания на вашем предприятии или в организации. Полнофункциональная 60-дневная бесплатная пробная версия.
вкладка kte 201905

Вкладка «Office» предоставляет интерфейс с вкладками для Office и упрощает работу

  • Включить редактирование и чтение с вкладками в Word, Excel, PowerPoint, Издатель, Доступ, Visio и Проект.
  • Открывайте и создавайте несколько документов в новых вкладках одного и того же окна, а не в новых окнах.
  • Увеличивает вашу производительность на 50% и уменьшает сотни щелчков мышью для вас каждый день!
нижняя часть офиса
</ p >

Say something here...
symbols left.
You are guest ( Sign Up? )
or post as a guest, but your post won't be published automatically.
Loading comment... The comment will be refreshed after 00:00.
  • To post as a guest, your comment is unpublished.
    José · 3 months ago
    This not work for me}
  • To post as a guest, your comment is unpublished.
    saravanan · 10 months ago
    not working , ye password set in your code not working in your code
  • To post as a guest, your comment is unpublished.
    dougs · 1 years ago
    I believe the reason that the row heights do not calculate properly is related to these lines of code
    For iPtr = 1 To oRange.Columns.Count
    oldWidth = oldWidth + .Cells(1, oRange.Column + iPtr - 1).ColumnWidth
    Next iPtr
    oldWidth = .Cells(1, oRange.Column).ColumnWidth + .Cells(1, oRange.Column + 1).ColumnWidth

    The variable OldWidth gets set to the sum of the column widths in the range, but for some reason it gets reset to only the width of the first two columns. The first 3 lines of code are therefore made redundant by the 4th line. When I removed the line it was much better, but the other issue I found was that you have to make sure that the font and font size of the temporary cell (ZZ1 in the example code) must match the font and size of the merged cells; otherwise, text will not wrap in the same way as the merged cells wrap and may not be the correct height.
  • To post as a guest, your comment is unpublished.
    tomoharu · 1 years ago
    I made add-in for Auto fit row height of multiple merged cells.
    Please use this, if you want to autofit row hight.
    [Release Ver2.6 · toowaki/AutoFitRowEx · GitHub]
    https://github.com/toowaki/AutoFitRowEx/releases/tag/2.6.2
    • To post as a guest, your comment is unpublished.
      ABC · 1 years ago
      This is pretty helpful, thanks!
  • To post as a guest, your comment is unpublished.
    Krishna · 1 years ago
    I am trying to understand the necessity of Line 19. You are assigning a value again to OldWidth. Can you please explain?
  • To post as a guest, your comment is unpublished.
    Chris · 2 years ago
    My code will not even run I just get a compile error when I try to call the AutoFitMergedCells - Expected Function or variable?
  • To post as a guest, your comment is unpublished.
    Aperture · 2 years ago
    Because the "helper" cell of ZZ1 is using the first row (column ZZ, row 1), if there is ANYTHING in row 1 taller than the text in the row you want to adjust, your resulting height will be taller than what you want.

    To fix this, I made the helper cell the same column as the first column in the oRange and set the row number to the very last row in Excel. Hope this helps you like it does me. 8)

    [u]My Code:[/u]

    Option Explicit
    Public Sub AutoFitAll()
    Call AutoFitMergedCells(Range("A2:Z2"))

    End Sub
    Public Sub AutoFitMergedCells(oRange As Range)
    Dim tHeight As Integer
    Dim iPtr As Integer
    Dim oldWidth As Single
    Dim oldZZWidth As Single
    Dim newWidth As Single
    Dim newHeight As Single
    With Sheets("Sheet1")
    oldWidth = 0
    For iPtr = 1 To oRange.Columns.Count
    oldWidth = oldWidth + .Cells(1, oRange.Column + iPtr - 1).ColumnWidth
    Next iPtr
    oldWidth = .Cells(1, oRange.Column).ColumnWidth + .Cells(1, oRange.Column + 1).ColumnWidth
    oRange.MergeCells = False
    newWidth = Len(.Cells(oRange.Row, oRange.Column).Value)
    oldZZWidth = .Cells("1048576", oRange.Column).ColumnWidth
    .Cells("1048576", oRange.Column) = Left(.Cells(oRange.Row, oRange.Column).Value, newWidth)
    .Cells("1048576", oRange.Column).WrapText = True
    .Columns(oRange.Column).ColumnWidth = oldWidth
    .Rows("1048576").EntireRow.AutoFit
    newHeight = .Rows("1048576").RowHeight / oRange.Rows.Count
    .Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).RowHeight = newHeight
    oRange.MergeCells = True
    oRange.WrapText = True
    .Cells("1048576", oRange.Column).ClearContents
    .Cells("1048576", oRange.Column).ColumnWidth = oldZZWidth
    End With
    End Sub
  • To post as a guest, your comment is unpublished.
    Retha · 2 years ago
    Thank you for the code. However, the height of my rows do adjust, but now enough. How can I rectify this?
  • To post as a guest, your comment is unpublished.
    Jeff · 2 years ago
    Thanks for posting this, I'm decent with excel and can usually figure out my adjustments but I can't seem to figure out a fix for an issue I'm having, or if one even exists. I have huge amounts of data in the cells (exceeding the single cell height limit of 409.5). The problem is this VBA runs with that same limitation. So some of my data gets cut off even though the rows are merged and the combined cell height allowance is 819, since the VBA adjusts the cell height based off the single ZZ1 cell. Is there anyway to adjust the code to get it to allow the adjusted cell height to include the available height in the merged rows or am I asking for the impossible? Thanks.
  • To post as a guest, your comment is unpublished.
    Vivi · 2 years ago
    Works perfect, but rows are too high! Can we fix this?
  • To post as a guest, your comment is unpublished.
    Hana · 2 years ago
    Brilliant but exactly the same problem as Danielle, rows are too high now. Please someone help!
  • To post as a guest, your comment is unpublished.
    Susan · 2 years ago
    Thanks so much for the code. Is there any way to make the macro run as soon as you type text in a field and hit enter?
  • To post as a guest, your comment is unpublished.
    Viktor · 3 years ago
    Thanks for the code, pretty much what I needed.

    Two remarks, though:
    1) when I run the macro in the same row as the "helper"cell (ZZ1), autofit (line 26) will mess up, because the whole string is fitted into one narow cell. I recommend adding

    oRange.WrapText = False

    in the beginning (or moving the helper cell somewhere out of the way, if possible).
    2) what's the purpose of line 19? You claculate oldWidth in lines 16-18, but then override the calculation in line 19, using only two columns. When I tried the sub on a three-column-wide merged cells, it worked better when I ignored the line...

    Thanks again
  • To post as a guest, your comment is unpublished.
    Afshin · 3 years ago
    Thanks a lot for the code! I have same problem with this code such as DANIËLLE_01.
  • To post as a guest, your comment is unpublished.
    Daniëlle_01 · 3 years ago
    Thanks a lot for the code! It finally works, but... My row height becomes too height. Is there a solution for?

    Thanks a lot!

    [u]This is my code:[/u]

    Option Explicit
    Public Sub AutoFitAll()
    Call AutoFitMergedCells(Range("b162:i162"))
    Call AutoFitMergedCells(Range("b166:i166"))
    Call AutoFitMergedCells(Range("b168:i168"))
    Call AutoFitMergedCells(Range("b170:i170"))
    Call AutoFitMergedCells(Range("b172:i172"))
    End Sub
    Public Sub AutoFitMergedCells(oRange As Range)
    Dim tHeight As Integer
    Dim iPtr As Integer
    Dim oldWidth As Single
    Dim oldZZWidth As Single
    Dim newWidth As Single
    Dim newHeight As Single
    With Sheets("Rapport")
    oldWidth = 0
    For iPtr = 1 To oRange.Columns.Count
    oldWidth = oldWidth + .Cells(1, oRange.Column + iPtr - 1).ColumnWidth
    Next iPtr
    oldWidth = .Cells(1, oRange.Column).ColumnWidth + .Cells(1, oRange.Column + 1).ColumnWidth
    oRange.MergeCells = False
    newWidth = Len(.Cells(oRange.Row, oRange.Column).Value)
    oldZZWidth = .Range("ZZ1").ColumnWidth
    .Range("ZZ1") = Left(.Cells(oRange.Row, oRange.Column).Value, newWidth)
    .Range("ZZ1").WrapText = True
    .Columns("ZZ").ColumnWidth = oldWidth
    .Rows("1").EntireRow.AutoFit
    newHeight = .Rows("1").RowHeight / oRange.Rows.Count
    .Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).RowHeight = newHeight
    oRange.MergeCells = True
    oRange.WrapText = True
    .Range("ZZ1").ClearContents
    .Range("ZZ1").ColumnWidth = oldZZWidth
    End With
    End Sub
    • To post as a guest, your comment is unpublished.
      Aperture · 2 years ago
      Because the "helper" cell of ZZ1 is using the first row (column ZZ, row 1), if there is ANYTHING in row 1 taller than the text in the row you want to adjust, your resulting height will be taller than what you want.

      To fix this, I made the helper cell the same column as the first column in the oRange and set the row number to the very last row in Excel. Hope this helps you like it does me. 8)

      [u]My Code:[/u]

      Option Explicit
      Public Sub AutoFitAll()
      Call AutoFitMergedCells(Range("A2:Z2"))

      End Sub
      Public Sub AutoFitMergedCells(oRange As Range)
      Dim tHeight As Integer
      Dim iPtr As Integer
      Dim oldWidth As Single
      Dim oldZZWidth As Single
      Dim newWidth As Single
      Dim newHeight As Single
      With Sheets("Sheet1")
      oldWidth = 0
      For iPtr = 1 To oRange.Columns.Count
      oldWidth = oldWidth + .Cells(1, oRange.Column + iPtr - 1).ColumnWidth
      Next iPtr
      oldWidth = .Cells(1, oRange.Column).ColumnWidth + .Cells(1, oRange.Column + 1).ColumnWidth
      oRange.MergeCells = False
      newWidth = Len(.Cells(oRange.Row, oRange.Column).Value)
      oldZZWidth = .Cells("1048576", oRange.Column).ColumnWidth
      .Cells("1048576", oRange.Column) = Left(.Cells(oRange.Row, oRange.Column).Value, newWidth)
      .Cells("1048576", oRange.Column).WrapText = True
      .Columns(oRange.Column).ColumnWidth = oldWidth
      .Rows("1048576").EntireRow.AutoFit
      newHeight = .Rows("1048576").RowHeight / oRange.Rows.Count
      .Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).RowHeight = newHeight
      oRange.MergeCells = True
      oRange.WrapText = True
      .Cells("1048576", oRange.Column).ClearContents
      .Cells("1048576", oRange.Column).ColumnWidth = oldZZWidth
      End With
      End Sub
    • To post as a guest, your comment is unpublished.
      Viktor · 3 years ago
      Hi Danielle,

      I ran into the same problem, when running the macro a second time in the first row. The code uses

      .Rows("1").EntireRow.AutoFit (line 26)

      and if you run in on, say A1:B1, your A1 cell has WordWrapping set to ON from line 30.

      The easiest solution seems to be switching WordWrapping off at the beginning of the sub. Add

      oRange.WrapText = True

      between lines 13 and 14 and you should be OK.
  • To post as a guest, your comment is unpublished.
    Dina · 3 years ago
    I have the following entered, but I get an error message "Run-time error '13': Type mismatch" Help?


    Option Explicit
    Public Sub AutoFitAll()
    Call AutoFitMergedCells(Range("a8:h8"))
    Call AutoFitMergedCells(Range("a10:h10"))
    Call AutoFitMergedCells(Range("a11:h11"))
    Call AutoFitMergedCells(Range("b17:h17"))
    Call AutoFitMergedCells(Range("b22:h22"))
    Call AutoFitMergedCells(Range("b24:h24"))
    Call AutoFitMergedCells(Range("a26:h26"))
    Call AutoFitMergedCells(Range("a28:h28"))

    End Sub
    Public Sub AutoFitMergedCells(oRange As Range)
    Dim tHeight As Integer
    Dim iPtr As Integer
    Dim oldWidth As Single
    Dim oldZZWidth As Single
    Dim newWidth As Single
    Dim newHeight As Single
    With Sheets("Offer Letter")
    oldWidth = 0
    For iPtr = 1 To oRange.Columns.Count
    oldWidth = oldWidth + .Cells(1, oRange.Column + iPtr - 1).ColumnWidth
    Next iPtr
    oldWidth = .Cells(1, oRange.Column).ColumnWidth + .Cells(1, oRange.Column + 1).ColumnWidth
    oRange.MergeCells = False
    newWidth = Len(.Cells(oRange.Row, oRange.Column).Value)
    oldZZWidth = .Range("ZZ1").ColumnWidth
    .Range("ZZ1") = Left(.Cells(oRange.Row, oRange.Column).Value, newWidth)
    .Range("ZZ1").WrapText = True
    .Columns("ZZ").ColumnWidth = oldWidth
    .Rows("1").EntireRow.AutoFit
    newHeight = .Rows("1").rowHeight / oRange.Rows.Count
    .Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).rowHeight = newHeight
    oRange.MergeCells = True
    oRange.WrapText = True
    .Range("ZZ1").ClearContents
    .Range("ZZ1").ColumnWidth = oldZZWidth
    End With
    End Sub
  • To post as a guest, your comment is unpublished.
    Joe Dell · 4 years ago
    This code causes additional rows to be deleted. I have numbers on left side and columns next to it are merged/wrapped data. For example, in a Job description, list responsibilities with numbers followed by explanation of duty. Any thoughts? Thanks.