Высота строки в зависимости от длины текста

[strannick]

Добрый день, уважаемые форумчане!
Параметры строк и столбцов в таблице регламентированы ГОСТом. Высота строки может быть либо 8мм, либо 16 мм. Ширина столбца 90 мм, шрифт Arial Narrow 10й. Ячейки настроены на перенос по словам.
Как в макросе прописать условие, когда длина текста превышает столько-то символов, то высота строки устанавливается в 16 мм? Или может какое-то другое условие можно использовать? Что-то типа:

If Cells(i, 4).Text > "90 символов" Then Rows(i).RowHeight = 16

Таблица - Ведомость покупных изделий (ГОСТ 2.104-2006).
Заранее спасибо!

[staniiislav]

наверное так:

Dim i&
For i = 1 To 10
    If Len(Cells(i, 4)) > 90 Then
        Rows(i).RowHeight = 16
    Else
        Rows(i).RowHeight = 8
    End If
Next i

[EducatedFool]

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

наверное так:

примерно так.
В Excel высота строк измеряется точно не в миллиметрах.

strannick, вам надо будет только подобрать методом научного тыка эти 2 значения (вместо 8 и 16)

[nerv]

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

примерно так.
В Excel высота строк измеряется точно не в миллиметрах.

она измеряется в пунктах (насколько помню). При желании можно перевести.

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

Как в макросе прописать условие, когда длина текста превышает столько-то символов, то высота строки устанавливается в 16 мм?

бесполезно, если шрифт не моноширинный. Ширина букв разная, кроме этого они СТРОЧНЫЕ и прописные

алгоритм:
1. подобрать высоту стандартным автоподбором
2. перевести в миллиметры
3. округлить до 8 или 16 мм

Могу реализовать, но не бесплатно.

[strannick]

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

strannick, вам надо будет только подобрать методом научного тыка эти 2 значения (вместо 8 и 16)

Это-то довольно легко. 8мм - это 22,5пт. Переводим в режим Разметки страницы, устанавливаем высоту строки в 0,8см (в этот режиме измерение идет в см.). Переходим в Обычный режим. Смотрим высоту этой строки = 22,5пт.
А вот насчет длины текста, то тут да, Придется опытным путем определять момент переноса. Благо дело используется только один шрифт.
staniiislav, спасибо за код. Попробую и отпишусь. Спасибо всем, тема пока не закрывается.

[Скрипт]

nerv: она измеряется в пунктах (насколько помню)

Может я чего-то не понимаю, но эта информация есть во встроенной VBA-справке.
В VBA в верхнем правом углу есть поле. Туда нужно скопировать и вставить вот этот текст RowHeight и нажать клавишу "Enter".

Откроется список статей, выбираем Range.RowHeight Property.


Вот цитата из справки:

Range.RowHeight Property
Returns the height of all the rows in the range specified, measured in points (point: Unit of measure referring to the height of a printed character. A point equals 1/72 of an inch, or approximately 1/28 of a centimeter.).

Points - это пункты.

[nerv]

Сообщение от Скрипт

Может я чего-то не понимаю, но эта информация есть во встроенной VBA-справке.

все верно. Ну не лезть же перед каждым ответом в справку/редатор кода. Долго)

Сообщение от Скрипт

Вот цитата из справки:

Range.RowHeight Property
Returns the height of all the rows in the range specified, measured in points (point: Unit of measure referring to the height of a printed character. A point equals 1/72 of an inch, or approximately 1/28 of a centimeter.).

Только ребята не договаривают, что эти константы могут меняться в зависимости от DPI системы.

http://social.msdn.microsoft.com/For...-9f4f2b58f697/
http://office.microsoft.com/en-us/ex...001151724.aspx

[Казанский]

А вот насчет длины текста, то тут да, Придется опытным путем определять момент переноса.

Сохраните в переменной высоту пустой строки (1 раз). После вставки текста сравните высоту строки с сохраненной. Если не изменилась - нет переноса, ставьте 8 мм. Если изменилась - есть перенос, ставьте 16 мм.

[nerv]

Сообщение от Казанский

Сохраните в переменной высоту пустой строки (1 раз). После вставки текста сравните высоту строки с сохраненной. Если не изменилась - нет переноса, ставьте 8 мм. Если изменилась - есть перенос, ставьте 16 мм.

Row.AutoFit
Row.RowHeight = IIf(Row.RowHeight <= 8, 8, 16)

[strannick]

Еще раз Добрый вечер всем!
Спасибо всем откликнувшимся и предложившим варианты решения. На дружественном форуме нашел решение следующего характера (взято отсюда http://www.excelworld.ru/forum/2-890-1, спасибо Serge_007 и RAN):

Option Explicit
Dim myLong  As Integer

Sub Text_to_Rows()

    Dim myCell As Range
    Dim li As Integer, le As Integer
    Dim strText, myText As String
    Dim Str As String, myStr As String, endStr As String
    Dim textLong As Integer, msg As Long, myType As Boolean
    Dim myTextCel As String, myTextCelEnd As String

    On Error GoTo END_
    'отключил ручную установку длины строки
    'If myLong <> 0 Then
    '    myLong = InputBox("Длинна строки установлена " & Chr(13) & Chr(13) _
                        & myLong & " знаков", , myLong)
    'Else
    '    myLong = InputBox("Длинна строки не задана" & Chr(13) & Chr(13) _
                        & "предлагается 116 знаков", , 116)
    'End If
    myLong = 55 'установил опытным путем длину строки
    Application.ScreenUpdating = False
    Set myCell = ActiveCell
    myText = ActiveCell.Value
    myText = Application.Trim(myText)
    textLong = Len(myText)
    strText = Split(myText, " ")
line1:
    For le = LBound(strText) To UBound(strText)
        If strText(le) <> "" Then
            myStr = Trim(strText(le)) + " "
            If textLong > myLong Then
                endStr = Str + myStr
                If Len(endStr) > myLong Then
                    li = li + 1
                    Rows(myCell.Row + li).Insert
                    Rows(ActiveSheet.UsedRange.Rows.Count + 10).Copy
                    Rows(myCell.Row + li).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                                                       SkipBlanks:=False, Transpose:=False
                    ' подкраска строки
                    'myCell.Offset(li, 0).Interior.Color = 16777164 'отключил заливку

                    myCell.Offset(li, 0) = Left(Str, (Len(Str) - 1))
                    myText = Right(myText, Len(myText) - (Len(Str)))
                    strText = Split(myText, " ")
                    Str = ""
                    textLong = Len(myText)
                    GoTo line1
                Else
                    Str = endStr
                End If
            Else
                li = li + 1
                Rows(myCell.Row + li).Insert
                Rows(ActiveSheet.UsedRange.Rows.Count + 10).Copy
                Rows(myCell.Row + li).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                                                   SkipBlanks:=False, Transpose:=False
                'myCell.Offset(li, 0).Interior.Color = 16777164 'отключил заливку
                myCell.Offset(li, 0) = myText
                GoTo Exit_
            End If
        End If
    Next le
Exit_:
    Application.CutCopyMode = False
    ' удалить исходную ячейку
    myCell.Delete 'вставка разделенного текста идет с исходной строки
    ' выделить исходную ячейку
    myCell.Select
    Application.ScreenUpdating = True
END_:
End Sub

Вариант более приемлемый, потому как не будет расширять лист вниз и можно сделать строки сразу высотой 8мм и не менять. Данный код разбивает текст в активной ячейке по строкам вниз начиная с активной.
Вопрос в том, как при наличии в одном столбце нескольких ячеек с длинным текстом (как во вложении). провести разбиение текста по строкам во всех ячейках? Понимаю, что надо привязать цикл, но как это сделать не въезжаю. Ведь разбивки текста диапазон будет расширяться вниз.
Прошу совета.