Страницы: 1
RSS
Можно ли объединенные ячейки выровнять по высоте текста (макросом)?
 
В одной ячейке это решается  переносом текста.
Можно ли как-то выровнять объединенную ячейку?
 
попробуйте Автоподбор высоты в Excel | Программы и макросы для Excel (excelvba.ru)
 
irabel, Спасибо, хорошая  вещь,  но  мне надстройка не подходит.
 
Код оттуда, работает для выделенных ячеек
Код
Sub Sel_UserAutoFit()
    UserAutoFit Selection
End Sub

Public Function UserAutoFit(ByRef objRange As Object) As Boolean
    Dim j&, q&, f&, l&, p&(3), cWh!, rHh!, I() As Box, cl() As Single, X As Object
    On Error GoTo L2
    With Application
        .ScreenUpdating = False
        'v = .ActiveWindow.View: .ActiveWindow.View = xlNormalView
        If TypeName(objRange) = "Range" Then
            With .Sheets(objRange.Parent.Name)    '.ActiveSheet
                ' .DisplayPageBreaks = False
                For Each X In objRange.Areas
                    Set X = IIf(X.Address = .Rows.Address Or X.Address = .Columns(X.Column).Address, .UsedRange, X): p(0) = X.Column
                    p(1) = p(0) + X.Columns.count - 1: p(2) = X.Row: p(3) = p(2) + X.Rows.count - 1: ReDim cl(p(0) To p(1)): ReDim I(p(2) To p(3))
                    For j = p(0) To p(1): cl(j) = .Columns(j).ColumnWidth: Next
                    For j = p(3) To p(2) Step -1
                        Set X = .Rows(j): I(j).Hdn = X.Hidden: X.AutoFit: I(j).Hght = X.RowHeight
                        For l = p(0) To p(1)
                            If .Cells(j, l).MergeCells Then
                                With .Cells(j, l).MergeArea
                                    If .Parent.Cells(j, l).Address = .item(1).Address Then
                                        For q = l To l + .Columns.count - 1: cWh = cWh + cl(q) + 0.647: Next
                                        If cWh > 255 Then cWh = 0: GoTo L1
                                        For q = j To j + .Rows.count - 1
                                            If Not I(q).Hdn Then rHh = rHh + I(q).Hght: If f = 0 Then f = q
                                        Next
                                        .UnMerge: .item(1).ColumnWidth = cWh: X.AutoFit: rHh = X.RowHeight - (rHh - I(f).Hght)
                                        If f <> j Then If I(f).Hght < rHh Then .Rows(f - j + 1).RowHeight = rHh
                                        .Merge: .item(1).ColumnWidth = cl(l): l = l + .Columns.count - 1
                                        If I(f).Hght < rHh Then I(f).Hght = rHh
                                        cWh = 0: rHh = 0: f = 0
                                    End If
                                End With
                            End If
L1:                             Next
                        If I(j).Hght > 0 Then X.RowHeight = I(j).Hght
                        If I(j).Hdn Then X.Hidden = True
                    Next
                Next
            End With
        End If
        ' .ActiveWindow.View = v
    End With
L2:     End Function
Страницы: 1
Наверх