Как изменить высоту строки по условию

[oleg4224]

Добрый день всем !
Выделил свой вопрос в отдельную тему тк непонятно как сделать - автоподбор высоты строки не помогает

Есть таблица - в ней есть ячейки в которых много текста (в моем примере в столбце D) , область таблицы A3:O5000, обьединенных ячеек нет

Автоподбор высоты строк срабатывает по максимальному тексту - при этом высота строки становится безумной тк много текста в одной из ячеек

Примерный алгоритм решения
1.Для строки 3
- выбираем диапазоны A3:C3 и E3:O3 (D3 исключаем тк в ней много текста)
- высоту строки 3 выставляем по самому максимальному заполнению одной из ячеек диапазона A3:C3 и E3:O3

2.Для строки 4
- выбираем диапазоны A4:C4 и E4:O4 (D4 исключаем тк в ней много текста)
- высоту строки 4 выставляем по самому максимальному заполнению одной из ячеек диапазона A4:C4 и E4:O4

и так далее до 5000 строки

Как это реализовать макросом ? Пример во вложении

[IgorGO]

может так:

Sub FitAsNeed()
  [d:d].WrapText = False:  Cells.EntireRow.AutoFit
End Sub

[Казанский]

С сохранением переноса по словам

Sub oleg4224()
Dim r As Range, f(), i&
Application.ScreenUpdating = False
With ActiveSheet.UsedRange
  f = .Columns(4).Formula
  .Columns(4).ClearContents
  Rows.AutoFit
  ReDim rh(1 To .Rows.Count)
  For i = 1 To UBound(rh)
    rh(i) = .Rows(i).RowHeight
  Next
  .Columns(4).Formula = f
  For i = 1 To UBound(rh)
    .Rows(i).RowHeight = rh(i)
  Next
End With
Application.ScreenUpdating = True
End Sub

[oleg4224]

Попробовал так сделать - пример был с кнопкой + совет Игоря

поправьте если что не так

еще щас попробую с сохранением переноса по словам уважаемого Казанский

[oleg4224]

спасибо Казанскому и Игорю за помощь!!

а как сделать так чтоб выравнивание строк не с 1 строки начиналось а с 3-й - что поменять в вашем макросе ?

Sub oleg4224()
Dim r As Range, f(), i&
Application.ScreenUpdating = False
With ActiveSheet.UsedRange
f = .Columns(4).Formula
.Columns(4).ClearContents
Rows.AutoFit
ReDim rh(1 To .Rows.Count)
For i = 1 To UBound(rh)
rh(i) = .Rows(i).RowHeight
Next
.Columns(4).Formula = f
For i = 1 To UBound(rh)
.Rows(i).RowHeight = rh(i)
Next
End With
Application.ScreenUpdating = True
End Sub

[IgorGO]

вот это
For i = 1 ...
не наводит на мысдь, что поменять (в макросе встречается 2 раза))

[oleg4224]

сижу 2 день - отупел уже - сэнкс спасибо за совет я про другую строку думал ReDim rh(1 To .Rows.Count) хотя простая замена For i = 1 на For i = 3 не помогает ... поэтому и спрашиваю