1 / 1 / 0
Регистрация: 12.02.2017
Сообщений: 52
1

Автоподбор высоты строки, объединенных по вертикали ячеек средствами VBA

12.11.2018, 17:37. Показов 6563. Ответов 3

Доброго времени суток!

Использую следующий макрос, но к сожалению выравнивание учитывает только наполнение каждой сроки, наполнение объединенных строк макрос не учитывает...

Visual Basic
1
2
3
4
Sub MergeDuplicates113333121124()
    iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(1, 1), Cells(iLastRow, 1)).EntireRow.AutoFit
    End Sub

Есть ли в Excel возможность средствами VBA автоматически подобрать высоту строки таким образом, чтобы в объединенных строках (ячейках по вертикали) текст был читаемым.

Прикладываю рисунок (справа ожидание, слева реальность).
Так же прикладываю электронную таблицу.
Миниатюры
Автоподбор высоты строки, объединенных по вертикали ячеек средствами VBA  
Вложения
Тип файла: xlsx пробный для форума.xlsx (9.8 Кб, 6 просмотров)
__________________
Помощь в написании контрольных, курсовых и дипломных работ, диссертаций здесь
0
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
12.11.2018, 17:37
Ответы с готовыми решениями:

Выравнивание высоты объединённых ячеек Excel по их содержимому. AutoFit для объединённых ячеек Excel.
В ячейку вставляется очень длинный текст, который при печати просто не виден. Нужно, чтобы...

Автоподбор ширины и высоты ячеек Excel
Добрый день, возникла проблема с работой из VB в excel. Проблема в следующем: 1. Из VB...

Автоподбор высоты строки в диапазоне
Добрый день! Необходимо сделать следующее: Если какой-либо ячейке из диапазона A1:C50 количество...

Как сделать автоподбор высоты строки в Excel
Добрый вечер. Столкнулся с такой бедой, в объединенную ячейку Excel вставляю текст, у ячейку...

3
1 / 1 / 0
Регистрация: 12.02.2017
Сообщений: 52
15.11.2018, 16:55  [ТС] 2
Наткунлся на схожую тему AutoFit объединённой ячейки. ColumnWidth и Columns(n).Width созданнуюtolikt
Предложенный вариант решения немного адаптировал под свою задачу, однако не получается реализовать одну из задумок.

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

Предположительный алгоритм таков

If HeighN>HeighG And HeighN>HeighF And HeighN/CountRows>HeighRow Then
newHeighRow = HeighN/CountRows
ElseIf HeighG >HeighN And HeighG >HeighF And HeighG/CountRows>HeighRow Then
newHeighRow = HeighG/CountRows
ElseIf HeighF>HeighN And HeighF>HeighG And HeighF/CountRows>HeighRow Then
newHeighRow = HeighF/CountRows

HeighN - Высота объединенной ячейки столбца N
HeighG - Высота объединенной ячейки столбца G
HeighF - Высота объединенной ячейки столбца F
HeighRow - Высота строки
newHeighRow - Новая высота строки
CountRows - Количество строк в объединенной ячейки

Попытка реализации описанного алгоритма не увенчалась успехом, поэтому прошу помощи умов сего ресурса.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Sub RowHeightFiting2_Naim()
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(1, 1), Cells(iLastRow, 1)).EntireRow.AutoFit
 
For Counter = 0 To iLastRow
Range("N3:N4").Offset(Counter, 0).Activate
 
' Объединённая ячейка должна быть активной!!! <FONT color=#dd33dd>' Если неактивна, то нужно переменной MyRanAdr присвоить ПОЛНЫЙ АДРЕС ОБЛАСТИ объединённой ячейки
Application.ScreenUpdating = False
Dim MyRanAdr As String
Dim MergeAreaTotalHeight, NewRH As Long
Dim MergeAreaFirstCellColWidth, MergeAreaFirstCellColHeight
 
MyRanAdr = ActiveCell.MergeArea.Address 'адрес области с объединённой ячейкой
MyRanAdrN = Range(MyRanAdr).Offset(, 0).MergeArea.Address 'адрес области с объединённой ячейкой N
MyRanAdrG = Range(MyRanAdr).Offset(, -7).MergeArea.Address 'адрес области с объединённой ячейкой G
MyRanAdrF = Range(MyRanAdr).Offset(, -8).MergeArea.Address 'адрес области с объединённой ячейкой F
 
MergeAreaTotalHeight = Range(MyRanAdr).Height ' высота всей объединённой ячейки в ед. пт
MergeAreaFirstCellColWidth = Range(MyRanAdr).Cells(1, 1).EntireColumn.ColumnWidth ' ширина первого столбца в объединённой ячейке
MergeAreaFirstCellColHeight = Range(MyRanAdr).Cells(1, 1).EntireRow.RowHeight ' высота первой строки в объединённой ячейке
Range(MyRanAdr).Cells(1, 1).ColumnWidth = (Range(MyRanAdr).Width - 3.75) / 4.5 'установка ширины первого столбца объед. ячейки равной общей ширине объед. ячейки  '''БЕЗ ПОДГОНКИ!!!
Range(MyRanAdr).WrapText = True
Range(MyRanAdr).MergeCells = False
Range(MyRanAdr).Cells(1, 1).EntireRow.AutoFit
NewRH = Range(MyRanAdr).Cells(1, 1).EntireRow.RowHeight
 
NewRHN = Range(MyRanAdrN).Cells(1, 1).EntireRow.RowHeight
NewRHG = Range(MyRanAdrG).Cells(1, 1).EntireRow.RowHeight
NewRHF = Range(MyRanAdrF).Cells(1, 1).EntireRow.RowHeight
 
Range(MyRanAdr).MergeCells = True
Range(MyRanAdr).Cells(1, 1).EntireColumn.ColumnWidth = MergeAreaFirstCellColWidth
'Range(MyRanAdr).Cells(1, 1).EntireRow.RowHeight = NewRH - (MergeAreaTotalHeight - MergeAreaFirstCellColHeight) ' для 1-й строки в объед.ячейке
'Range(MyRanAdr).EntireRow.RowHeight = NewRH / Range(MyRanAdr).Rows.Count 'для равной высоты всех строк в объед.ячейке
 
'MsgBox ("Строка№ " & 3 + Counter & vbCrLf & "Новая высота объед строки= " & NewRH & vbCrLf & "Новая высота 1 строки" & NewRH / Range(MyRanAdr).Rows.Count & vbCrLf & "Старая высота 1 строки" & Cells(3 + Counter, 4).EntireRow.RowHeight)
 
 
'If NewRH > NewRHG And NewRH > NewRHF And NewRH > Cells(3 + Counter, 4).EntireRow.RowHeight Then
'Range(MyRanAdr).EntireRow.RowHeight = NewRH / Range(MyRanAdr).Rows.Count 'для равной высоты всех строк в объед.ячейке
If NewRHG > NewRH And NewRHG > NewRHF And NewRHG > Cells(3 + Counter, 4).EntireRow.RowHeight Then
'ElseIf NewRHG > NewRH And NewRHG > NewRHF And NewRHG > Cells(3 + Counter, 4).EntireRow.RowHeight Then
Range(MyRanAdrG).EntireRow.RowHeight = NewRHG / Range(MyRanAdrG).Rows.Count 'для равной высоты всех строк в объед.ячейке
'ElseIf NewRHF > NewRH And NewRHF > NewRHG And NewRHF > Cells(3 + Counter, 4).EntireRow.RowHeight Then
'Range(MyRanAdrF).EntireRow.RowHeight = NewRHF / Range(MyRanAdrF).Rows.Count 'для равной высоты всех строк в объед.ячейке
Else
End If
 
Next Counter
Application.ScreenUpdating = True
End Sub
Пример таблицы с макросом прикладываю во вложение.
Вложения
Тип файла: xls протокол-форум.xls (80.5 Кб, 12 просмотров)
0
3217 / 966 / 223
Регистрация: 29.05.2010
Сообщений: 2,080
15.11.2018, 21:29 3
Попробуй такой вариант на 1 блоке:
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
'выделить первый блок A1:E6 и запустить макрос
Sub pr()
    Dim a(), i&, x As Range
    For Each x In Selection.Cells
        If x.MergeCells Then
            ReDim Preserve a(i)
            a(i) = x.MergeArea.Address
            i = i + 1
            x.UnMerge
        End If
    Next
    With Selection
        kRow = .Rows.Count
        .Rows.AutoFit
        HeigthRows = .Height
        For Each el In a
            Range(el).Merge
        Next
        .RowHeight = HeigthRows / kRow
    End With
End Sub

Ну а выбор диапазона и зациклить уж сам
0
123 / 59 / 14
Регистрация: 29.03.2015
Сообщений: 265
30.11.2020, 20:57 4
Ох уж этот AutoFit
На скорую руку я выкрутился так:

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
Public Function get_row_autofit_height(ByRef SR As Range, Optional ByVal TX As String = Empty, Optional ByVal CW As Single) As Single
    ' SR - ячейка с требуемым форматом, для которой нужно получить высоту текста
    ' CW - требуемая ширина столбца
    ' TX - текст
    
    Dim R As Single         ' результат
    Dim B As Workbook       ' временная книга
    
    ' Application.ScreenUpdating регулируется до вызова
    
    ' создать новую временную книгу
    Set B = Application.Workbooks.Add
    
    ' отформатировать почти по образцу ячейку А1
    With B.Worksheets(1).Range("A1:A1")
        .HorizontalAlignment = SR.HorizontalAlignment
        .VerticalAlignment = SR.VerticalAlignment
        .Orientation = SR.Orientation
        .AddIndent = SR.AddIndent
        .IndentLevel = SR.IndentLevel
        .ShrinkToFit = SR.ShrinkToFit
        .WrapText = True
        .ReadingOrder = SR.ReadingOrder
        .MergeCells = False
            ' установить требуемую ширину ячейке А1
            If CW > 0 Then .ColumnWidth = CW        ' если это диапазон то что-то нужно предпринять, но этого не сделано
            ' присвоить требуемый текст ячейке А1
            If TX = Empty Then .Value = SR.Value Else .Value = TX
    End With
    
    ' так как чёртов AutoFit отталкивается от шрифта стиля то
    ' изменить шрифт по образцу в стиле 'normal'
    With B.Styles("Normal").Font
        .Name = SR.Font.Name
        .Size = SR.Font.Size
        .Bold = SR.Font.Bold
        .Italic = SR.Font.Italic
        .Underline = SR.Font.Underline
        .Strikethrough = SR.Font.Strikethrough
    End With
    
    ' на всякий случай
    ' изменить шрифт по образцу ячейке А1
    With B.Worksheets(1).Range("A1:A1").Font
        .Name = SR.Font.Name
        .Size = SR.Font.Size
        .Bold = SR.Font.Bold
        .Italic = SR.Font.Italic
        .Underline = SR.Font.Underline
        .Strikethrough = SR.Font.Strikethrough
    End With
    
    ' применить автовысоту
    B.Worksheets(1).Range("A1:A1").EntireRow.AutoFit
    
    ' запомнить результат
    R = B.Worksheets(1).Range("A1:A1").RowHeight
    
    ' закрыть временную книгу без сохранений
    B.Close False
    
    ' вернуть результат
    get_row_autofit_height = R
End Function


Если диапазон содержит несколько столбцов то в функцию передаю сумму ширин столбцов диапазона
Если диапазон содержит несколько строк то функцию вызываю для каждой строки
Мне не нравиться такой метод, но лучшего не придумал
1
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
30.11.2020, 20:57
Помогаю со студенческими работами здесь

Выделение строки методом CSS с учетом объединенных ячеек
Подскажите, как используя только CSS выделить строку и объединенную ячейку как на рисунках. На...

Как средствами VBA выровнять столбец по содержимому ячеек?
Как средствами VBA выровнять столбец по содержимому ячеек? Поиск не помог Спасибо!)

Как скопировать диапазон ячеек с одной части таблицы в другую пользуясь средствами VBA?
Это наверно очень просто, но никак пока не получается. Как скопировать диапазон ячеек с одной части...

Excel - Перенос по словам или автоподбор высоты после вне работают как нужно
Доброе время суток Не пойму, это глюк или это такая логика: Открываю Excel, выделяю строки,...

Перенос объединенных ячеек
Добрый день, есть 2 документа в одном надо взять первые 5 ячеек(не объединенных) и вставить во...

Копирование объединённых ячеек
Добрый день! У меня есть макрос, который должен копировать проект - строку с первого листа и...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
4
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin
Copyright ©2000 - 2022, CyberForum.ru