none
Проблема в Excel с Rows.AutoFit и объединенными колонками RRS feed

  • Вопрос

  • Здравствуйте.
    Заметил, что не всегда работает Rows.AutoFit для установки высоты колонки. А именно для случаев, когда в ячейку помещен текст с символами переноса строки и ячейка объединена с другими.
    Пример кода:
    Range("B1:C1").Merge
    Range("B1:C1").Value="Str1"&CStr(vbCrLf)&"Str2"
    Range("B1:C1").WrapText=true
    Range("B1:C1").Rows.AutoFit
    В итоге получаем одну строку, в которой отображается только Str1
    Если убрать объединение, то метод работает.
    Range("B1:C1").UnMerge
    Range("B1:C1").Rows.AutoFit
    После выполнения этих строк видим то, что ожидаем: две строки Str1 и Str2

    Пока единственный выход, который нашел - испольовать свойство RowHeight и вручную формировать высоту строк. Но это не очень удобно.
    23 сентября 2011 г. 5:45

Ответы

  • Грег Вилсон написал для подобной ситуации неплохой скрипт:

    Private Sub Worksheet_Change(ByVal Target As Range) 
    Dim NewRwHt As Single 
    Dim cWdth As Single, MrgeWdth As Single 
    Dim c As Range, cc As Range 
    Dim ma As Range 
    
    With Target 
    If .MergeCells And .WrapText Then 
    Set c = Target.Cells(1, 1) 
    cWdth = c.ColumnWidth 
    Set ma = c.MergeArea 
    For Each cc In ma.Cells 
    MrgeWdth = MrgeWdth + cc.ColumnWidth 
    Next 
    Application.ScreenUpdating = False 
    ma.MergeCells = False 
    c.ColumnWidth = MrgeWdth 
    c.EntireRow.AutoFit 
    NewRwHt = c.RowHeight 
    c.ColumnWidth = cWdth 
    ma.MergeCells = True 
    ma.RowHeight = NewRwHt 
    cWdth = 0: MrgeWdth = 0 
    Application.ScreenUpdating = True 
    End If 
    End With 
    End Sub 
    
    

    Думаю, в качестве базы для вашей задачи подойдет.


    Мнения, высказанные здесь, являются отражением моих личных взглядов, а не позиции корпорации Microsoft. Вся информация предоставляется "как есть" без каких-либо гарантий
    Follow MSTechnetForum on Twitter

    Посетите Блог Инженеров Доклады на Techdays: http://www.techdays.ru/speaker/Vinokurov_YUrij.html
    • Помечено в качестве ответа Dmitry Davydov 10 октября 2011 г. 9:20
    • Снята пометка об ответе Sergey Enns 11 октября 2011 г. 14:09
    • Помечено в качестве ответа Sergey Enns 11 октября 2011 г. 14:38
    5 октября 2011 г. 9:00
    Модератор
  • Спасибо, это не совсем то, что надо.

    Это как раз и есть способ установки вручную, о котором я упомянул. Для решения моей задачи пример конечно надо еще дополнить выбором поддиапазонов (Range.MergeCells для диапазона, частично включающего объединенные ячейки, возвращает null) и выбором макс. высоты из каждого диапазона

    Получается примерно так:

    Private Sub update(ByVal Target As Range)
        Dim NewRwHt As Single
        Dim cWdth As Single, MrgeWdth As Single
        Dim c As Range, cc As Range
        Dim ma As Range
        Dim MaxRHt
        
        MaxRHght = Target.Cells(1).RowHeight
        
        With Target
            For Each c In .Rows.Cells
                If (c.MergeCells And c.WrapText And c.MergeArea.Cells(1) = c) Then
                    Set ma = c.MergeArea
                    For Each cc In ma.Cells
                        MrgeWdth = MrgeWdth + cc.ColumnWidth
                    Next
                    cWdth = c.ColumnWidth
                    Application.ScreenUpdating = False
                    ma.MergeCells = False
                    c.ColumnWidth = MrgeWdth
                    c.EntireRow.AutoFit
                    NewRwHt = c.RowHeight
                    If (NewRwHt < MaxRHt) Then NewRwHt = MaxRHt
                    c.ColumnWidth = cWdth
                    ma.MergeCells = True
                    ma.RowHeight = NewRwHt
                    MaxRHt = NewRwHt
                    cWdth = 0: MrgeWdth = 0
                    Application.ScreenUpdating = True
                End If
            Next
        End With
    End Sub

    • Изменено Sergey Enns 11 октября 2011 г. 15:53
    • Помечено в качестве ответа Sergey Enns 11 октября 2011 г. 15:53
    11 октября 2011 г. 14:37

Все ответы

  • Грег Вилсон написал для подобной ситуации неплохой скрипт:

    Private Sub Worksheet_Change(ByVal Target As Range) 
    Dim NewRwHt As Single 
    Dim cWdth As Single, MrgeWdth As Single 
    Dim c As Range, cc As Range 
    Dim ma As Range 
    
    With Target 
    If .MergeCells And .WrapText Then 
    Set c = Target.Cells(1, 1) 
    cWdth = c.ColumnWidth 
    Set ma = c.MergeArea 
    For Each cc In ma.Cells 
    MrgeWdth = MrgeWdth + cc.ColumnWidth 
    Next 
    Application.ScreenUpdating = False 
    ma.MergeCells = False 
    c.ColumnWidth = MrgeWdth 
    c.EntireRow.AutoFit 
    NewRwHt = c.RowHeight 
    c.ColumnWidth = cWdth 
    ma.MergeCells = True 
    ma.RowHeight = NewRwHt 
    cWdth = 0: MrgeWdth = 0 
    Application.ScreenUpdating = True 
    End If 
    End With 
    End Sub 
    
    

    Думаю, в качестве базы для вашей задачи подойдет.


    Мнения, высказанные здесь, являются отражением моих личных взглядов, а не позиции корпорации Microsoft. Вся информация предоставляется "как есть" без каких-либо гарантий
    Follow MSTechnetForum on Twitter

    Посетите Блог Инженеров Доклады на Techdays: http://www.techdays.ru/speaker/Vinokurov_YUrij.html
    • Помечено в качестве ответа Dmitry Davydov 10 октября 2011 г. 9:20
    • Снята пометка об ответе Sergey Enns 11 октября 2011 г. 14:09
    • Помечено в качестве ответа Sergey Enns 11 октября 2011 г. 14:38
    5 октября 2011 г. 9:00
    Модератор
  • Спасибо, это не совсем то, что надо.

    Это как раз и есть способ установки вручную, о котором я упомянул. Для решения моей задачи пример конечно надо еще дополнить выбором поддиапазонов (Range.MergeCells для диапазона, частично включающего объединенные ячейки, возвращает null) и выбором макс. высоты из каждого диапазона

    Получается примерно так:

    Private Sub update(ByVal Target As Range)
        Dim NewRwHt As Single
        Dim cWdth As Single, MrgeWdth As Single
        Dim c As Range, cc As Range
        Dim ma As Range
        Dim MaxRHt
        
        MaxRHght = Target.Cells(1).RowHeight
        
        With Target
            For Each c In .Rows.Cells
                If (c.MergeCells And c.WrapText And c.MergeArea.Cells(1) = c) Then
                    Set ma = c.MergeArea
                    For Each cc In ma.Cells
                        MrgeWdth = MrgeWdth + cc.ColumnWidth
                    Next
                    cWdth = c.ColumnWidth
                    Application.ScreenUpdating = False
                    ma.MergeCells = False
                    c.ColumnWidth = MrgeWdth
                    c.EntireRow.AutoFit
                    NewRwHt = c.RowHeight
                    If (NewRwHt < MaxRHt) Then NewRwHt = MaxRHt
                    c.ColumnWidth = cWdth
                    ma.MergeCells = True
                    ma.RowHeight = NewRwHt
                    MaxRHt = NewRwHt
                    cWdth = 0: MrgeWdth = 0
                    Application.ScreenUpdating = True
                End If
            Next
        End With
    End Sub

    • Изменено Sergey Enns 11 октября 2011 г. 15:53
    • Помечено в качестве ответа Sergey Enns 11 октября 2011 г. 15:53
    11 октября 2011 г. 14:37