Страницы: 1
RSS
Подбор ширины столбца в объединенной ячейке макросом, Объединенные ячейки - зло!
 
Имеется счет-фактура, которую выплевывает 1С.
По договору точность отображения цены составляет 11 знаков после запятой.
Кроме того, имеется замороченный сотрудник контрагента, который докапывается до каждой запятой в документе.
Для успокоения этого сотрудника применяется нехитрый
Код
Set rSF = .Cells.Find("Цена (тариф) за единицу измерения", , , xlPart)
If Not rSF Is Nothing Then
    rSF.Offset(2, 0).NumberFormat = "#,##0.00000000000"
End If 
После него бывало, что число не влезает в ячейку и отображается  как "#########"
Решался вопрос просто:
rSF.EntireColumn.AutoFit

Однако ребятам в 1С тоже хочется кушать и они выпускают новую версию, где rSF является объединенной ячейкой и соответственно плюет на .EntireColumn.AutoFit

Замороченный сотрудник в ярости, я боюсь за его душевное здоровье. Как мне его спасти без потери своего душевного здоровья?
Вообще давно интересовал вопрос: есть некое содержимое ячейки .Value, кроме того про ячейку я знаю вид и размер шрифта, перенос строк и т.п.
Как эти знания перевести в ширину столбца?
Bite my shiny metal ass!      
 
Хм...делал я такое где-то уже...Надо поковырять - тоже с накладными возился. Выводил в отдельную функцию, кстати.
Вот, нашел:

Код
'---------------------------------------------------------------------------------------
' Procedure : RowHeightForContent
' DateTime  : 20.03.2012 15:28
' Author    : The_Prist(Щербаков Дмитрий)
'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
'             http://www.excel-vba.ru
' Purpose   : Функция подбирает ширину объединенных ячеек по содержимому(можно и под высоту подстроить)
'---------------------------------------------------------------------------------------
Function RowHeightForContent(rc As Range)
    Dim OldR_Height As Single, OldC_Widht As Single
    Dim MergedR_Height As Single, MergedC_Widht As Single
    Dim CurrCell As Range
    Dim ih As Integer
    Dim iw As Integer
    Dim NewR_Height As Single, NewC_Widht As Single
    Dim ActiveCellHeight As Single

    If rc.MergeCells Then
        With rc.MergeArea
            If .WrapText = True Then
                'запоминаем кол-во столбцов
                iw = .Columns(.Columns.Count).Column - rc.Column + 1
                'запоминаем кол-во строк.
                ih = .Rows(.Rows.Count).Row - rc.Row + 1
                'Ищем длину и ширину объединения ячеек.
                MergedR_Height = 0
                For Each CurrCell In .Rows
                    MergedR_Height = CurrCell.RowHeight + MergedR_Height
                Next
                MergedC_Widht = 0
                For Each CurrCell In .Columns
                    MergedC_Widht = CurrCell.ColumnWidth + MergedC_Widht
                Next
                OldR_Height = .Cells(1, 1).RowHeight
                OldC_Widht = .Cells(1, 1).ColumnWidth
                .MergeCells = False
                .Cells(1).RowHeight = MergedR_Height
                .Cells(1, 1).EntireColumn.ColumnWidth = MergedC_Widht
                .EntireRow.AutoFit
                NewR_Height = .Cells(1).RowHeight 'запоминаем высоту строки
                .MergeCells = True
                If OldR_Height < (NewR_Height / ih) Then
                    .RowHeight = NewR_Height / ih
                Else
                    .RowHeight = OldR_Height
                End If
                'возвращаем ширину столбца первой ячейки
                .Cells(1, 1).EntireColumn.ColumnWidth = OldC_Widht
            End If
        End With
    End If
End Function
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
The_Prist, Спасибо!
Воткнул не глядя:
Код
If Not rSF Is Nothing Then
 rSF.Offset(2, 0).NumberFormat = "#,##0.00000000000"
'rSF.EntireColumn.AutoFit
y = RowHeightForContent(rSF.Offset(2, 0))
End If 
Работает!
Bite my shiny metal ass!      
 
Не, поторопился
Это второй хороший Ваш код, но он про .EntireRow.AutoFit
А про EntireColumn.AutoFit поищете?
Bite my shiny metal ass!      
 
Что-то вроде:
Код
'---------------------------------------------------------------------------------------
' Procedure : RowHeightForContent
' DateTime  : 23.01.2015 16:02
' Author    : The_Prist(Щербаков Дмитрий)
'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
'             http://www.excel-vba.ru
' Purpose   : Функция подбирает высоту строки объединенных ячеек по содержимому
'---------------------------------------------------------------------------------------
Function RowColHeightForContent(rc As Range, Optional bRowHeight As Boolean = True)
    Dim OldR_Height As Single, OldC_Widht As Single
    Dim MergedR_Height As Single, MergedC_Widht As Single
    Dim CurrCell As Range
    Dim ih As Integer
    Dim iw As Integer
    Dim NewR_Height As Single, NewC_Widht As Single
    Dim ActiveCellHeight As Single

    If rc.MergeCells Then
        With rc.MergeArea
            If .WrapText = True Then
                'запоминаем кол-во столбцов
                iw = .Columns(.Columns.Count).Column - rc.Column + 1
                'запоминаем кол-во строк.
                ih = .Rows(.Rows.Count).Row - rc.Row + 1
                'Ищем длину и ширину объединения ячеек.
                MergedR_Height = 0
                For Each CurrCell In .Rows
                    MergedR_Height = CurrCell.RowHeight + MergedR_Height
                Next
                MergedC_Widht = 0
                For Each CurrCell In .Columns
                    MergedC_Widht = CurrCell.ColumnWidth + MergedC_Widht
                Next
                OldR_Height = .Cells(1, 1).RowHeight
                OldC_Widht = .Cells(1, 1).ColumnWidth
                .MergeCells = False
                .Cells(1).RowHeight = MergedR_Height
                .Cells(1, 1).EntireColumn.ColumnWidth = MergedC_Widht
                If bRowHeight Then
                    .EntireRow.AutoFit
                    NewR_Height = .Cells(1).RowHeight    'запоминаем высоту строки
                    .MergeCells = True
                    If OldR_Height < (NewR_Height / ih) Then
                        .RowHeight = NewR_Height / ih
                    Else
                        .RowHeight = OldR_Height
                    End If
                    'возвращаем ширину столбца первой ячейки
                    .Cells(1, 1).EntireColumn.ColumnWidth = OldC_Widht
                Else
                    .EntireColumn.AutoFit
                    NewC_Widht = .Cells(1).EntireColumn.ColumnWidth    'запоминаем ширину столбца
                    .MergeCells = True
                    If OldC_Widht < (NewC_Widht / iw) Then
                        .ColumnWidth = NewC_Widht / iw
                    Else
                        .ColumnWidth = OldC_Widht
                    End If
                    'возвращаем высоту строки первой ячейки
                    .Cells(1, 1).RowHeight = OldR_Height
                End If
                
            End If
        End With
    End If
End Function
Т.е. универсальная для обоих случаев. Отвечает за это доп.параметр: bRowHeight.
В случае с автоподбором высоты строки вызывается как и раньше. Для ширины столбцов:
Код
RowColHeightForContent Range("K17"), False
И есть нюанс: код будет работать только если в изменяемой объединенной ячейке установлен перенос текста: .WrapText = True
В принципе, данную строку можно и убить. Но я таким образом "помечал" ячейки, которые надо изменять.

P.S. Думаю, мы с Вами вполне можем на ты общаться.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Спасибо!
Выкинул  If .WrapText = True Then за ненадобностью.
Отлично работает :)
Единственная проблема может возникнуть в других строках, в которых тоже объединенные ячейки, но объединены другие столбцы  - там может поехать, так как ширина всех столбцов становится одинаковой. Хорошо, что мне надо только одну (пока одну, пока 1С еще не замутил) и ее можно выравнивать последней.


Да, вполне можно на ты :)
Просто я по умолчанию всегда на Вы. Прошу меня извинить, если я забуду и опять начну выкать :)  :oops:
Bite my shiny metal ass!      
 
Рад, что помогло.
.WrapText = True - оно очень нужно, когда надо подбор по высоте строк сделать.

Да я тоже тот еще Выкальщик :-)
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
А я сначала подумал, что без этого вообще не работает, потом голову ломал зачем таким странным способом метить ячейки. О_о
Bite my shiny metal ass!      
Страницы: 1
Наверх