Форум программистов, компьютерный форум, киберфорум
Наши страницы
Delphi для начинающих
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.62/87: Рейтинг темы: голосов - 87, средняя оценка - 4.62
Fistashka
0 / 0 / 0
Регистрация: 02.12.2011
Сообщений: 16
1

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

19.12.2011, 00:26. Просмотров 18187. Ответов 6

В ячейку вставляется очень длинный текст, который при печати просто не виден. Нужно, чтобы продолжение текста переносилось в сторку ниже.
Пишу на Delphi.
0
QA
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
19.12.2011, 00:26
Ответы с готовыми решениями:

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

Excel 2013 - как заполнить ряд вертикальных ячеек суммарным значением с учётом соседних ячеек?
Есть таблица в Excel 2013 c ячейками с форматом Общий. В первом столбце = 3-4 цифры (например,...

Скопировать диапазон ячеек одной книги Excel в другую книгу Excel
Из темы все ясно... Не могу разобраться никак. Можно ли открыть одну книгу, скопировать диапазон...

Excel 2010. Цвет заливки ячеек не переносится в Excel 2003
Добрый день! Закрасил ячейки в Excel 2010 стандартной палитрой по умолчанию. Открываю файл в...

Палитра для заливки ячеек Excel 2003
Сегодня баловался с палитрой - получилась отличная от Microsoft, что всплывает на панеле. И на 4...

6
Mawrat
12880 / 5782 / 1704
Регистрация: 19.09.2009
Сообщений: 8,807
19.12.2011, 04:05 2
Лучший ответ Сообщение было отмечено как решение

Решение

Для такой ячейки надо выставить свойство WrapText := True.
Delphi
1
2
3
4
5
var
  exCell, ... : Variant;
begin
...
  exCell.WrapText := True; //Перенос текста по словам.
После того, как во всех ячейках нужного диапазона текст будет установлен, можно выполнить подбор высоты строк так, чтобы весь текст с учётом переносов оказался видимым:
Delphi
1
2
3
4
5
var
  exRange, ... : Variant;
begin
...
  exRange.Rows.AutoFit; //Подпор высоты строк по содержимому ячеек.
Также можно выполнять подгонку ширины столбцов:
Delphi
1
2
3
4
5
var
  exRange, ... : Variant;
begin
...
  exRange.Columns.AutoFit; //Подпор ширины столбцов по содержимому ячеек.
4
Fistashka
0 / 0 / 0
Регистрация: 02.12.2011
Сообщений: 16
19.12.2011, 13:11  [ТС] 3
Цитата Сообщение от Mawrat Посмотреть сообщение
Для такой ячейки надо выставить свойство WrapText := True.
Delphi
1
2
3
4
5
var
  exCell, ... : Variant;
begin
...
  exCell.WrapText := True; //Перенос текста по словам.
После того, как во всех ячейках нужного диапазона текст будет установлен, можно выполнить подбор высоты строк так, чтобы весь текст с учётом переносов оказался видимым:
Delphi
1
2
3
4
5
var
  exRange, ... : Variant;
begin
...
  exRange.Rows.AutoFit; //Подпор высоты строк по содержимому ячеек.
Также можно выполнять подгонку ширины столбцов:
Delphi
1
2
3
4
5
var
  exRange, ... : Variant;
begin
...
  exRange.Columns.AutoFit; //Подпор ширины столбцов по содержимому ячеек.
Спасибо большое, буду пытаться )))

Добавлено через 1 час 11 минут
Цитата Сообщение от Mawrat Посмотреть сообщение
Для такой ячейки надо выставить свойство WrapText := True.
Delphi
1
2
3
4
5
var
  exCell, ... : Variant;
begin
...
  exCell.WrapText := True; //Перенос текста по словам.
После того, как во всех ячейках нужного диапазона текст будет установлен, можно выполнить подбор высоты строк так, чтобы весь текст с учётом переносов оказался видимым:
Delphi
1
2
3
4
5
var
  exRange, ... : Variant;
begin
...
  exRange.Rows.AutoFit; //Подпор высоты строк по содержимому ячеек.
Также можно выполнять подгонку ширины столбцов:
Delphi
1
2
3
4
5
var
  exRange, ... : Variant;
begin
...
  exRange.Columns.AutoFit; //Подпор ширины столбцов по содержимому ячеек.
Все хорошо, но возникает проблема: AutoFit не работает с объединенными ячейками, а у меня именно такие.
0
Mawrat
12880 / 5782 / 1704
Регистрация: 19.09.2009
Сообщений: 8,807
20.12.2011, 21:20 4
Цитата Сообщение от Fistashka Посмотреть сообщение
Все хорошо, но возникает проблема: AutoFit не работает с объединенными ячейками, а у меня именно такие.
Если ячейки объединены по нескольким строкам, то тогда неизвестно для каких из этих строк следует подгонять высоту. Ведь это можно сделать разными способами, изменяя высоту той или иной строки, в пределах объединения. Поэтому метод AutoFit не выполняет изменений для объединённых ячеек.
Такую задачу можно решать по-разному в зависимости от особенностей расположения данных на листе. Например, можно принять такое решение: в случае обнаружения объединения ячеек будем подгонять высоту только верхней строки, входящей в объединение. При этом, изменять высоту, если потребуется, будем только в сторону увеличения. Уменьшать высоту не будем, чтобы не нарушить соотношения по уже сделанным ранее объединениям.
По этому условию в VBA у меня получился такой код:
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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Option Explicit
 
'Эта процедура предназначена для подгона высоты строк по содержимому ячеек
'в пределах заданного диапазона aRng.
Sub RngAutoFit(ByRef aRng As Excel.Range)
  Dim Cell As Excel.Range 'Отдельная ячейка.
  Dim MRng As Excel.Range 'Диапазон объединения ячеек.
  Dim DispAl As Boolean
  Dim nRow As Long
  Dim nCol As Long
  Dim HRow1 As Long 'Высота верхней строки в диапазоне объединения.
  Dim H1 As Long 'Исходная высота по совокупности всех строк объединения.
  Dim H2 As Long 'Наименьшая необходимая высота для показа текста в объединённой ячейке.
  Dim WCol1 As Long 'Исходная ширина левого столбца в диапазоне объединения.
  Dim W1 As Long 'Исходная ширина по совокупности всех столбцов объединения.
  Dim i As Long
  
  If aRng Is Nothing Then Exit Sub
  
  'Подгоняем высоту строк для ячеек, которые не входят в диапазоны объединённых ячеек.
  aRng.Rows.AutoFit
  'Отключаем режим показа предупреждений. Это надо для того, чтобы в следующей части
  'программы не появлялось сообщение с предупреждением о последствиях объединения.
  DispAl = Application.DisplayAlerts
  Application.DisplayAlerts = False
  
  'Перебор всех ячеек диапазона.
  For nRow = 1 To aRng.Rows.Count
  For nCol = 1 To aRng.Columns.Count
    'Берём очередную ячейку.
    Set Cell = aRng.Cells(nRow, nCol)
    'Определяем диапазон объединения, в который входит ячейка Cell.
    Set MRng = Cell.MergeArea
    'Если в самом деле ячейка принадлежит диапазону объединённых ячеек и эта ячейка
    'является левой верхней ячейкой в этом диапазоне, тогда запускаем алгоритм подгона высоты.
    If Cell.MergeCells And (Cell = MRng.Cells(1, 1)) Then
      'Высота верхней строки в диапазоне объединения.
      HRow1 = MRng.Rows(1).RowHeight
      'Подсчитываем исходную высоту диапазона объединения по совокупности всех его строк.
      H1 = HRow1
      For i = 2 To MRng.Rows.Count
        H1 = H1 + MRng.Rows(i).RowHeight
      Next i
      'Ширина левого столбца в диапазоне объединения.
      WCol1 = MRng.Columns(1).ColumnWidth
      'Подсчитываем исходную ширину диапазона объединения по совокупности всех его столбцов.
      W1 = WCol1
      For i = 2 To MRng.Columns.Count
        W1 = W1 + MRng.Columns(i).ColumnWidth
      Next i
      'Теперь разъединяем ячейки.
      MRng.MergeCells = False
      'Ширину левого столбца делаем равным исходной ширине всего диапазона объединения.
      Cell.ColumnWidth = W1
      'Задаём режим переноса текста по словам.
      Cell.WrapText = True
      'Выполняем подгон высоты верхней строки.
      Cell.Rows.AutoFit
      'Выполняем замер получившейся высоты верхней строки.
      'Это наименьшая высота, пригодная для показа текста.
      H2 = Cell.Rows(1).RowHeight
      'Если исходная высота диапазона объединения оказалась меньше, чем наименьшая
      'пригодная высота, то увеличиваем высоту верхней строки на соответствующую величину.
      If H1 < H2 Then
        Cell.Rows(1).RowHeight = HRow1 + (H2 - H1)
      End If
      'Возвращаем левому столбцу диапазона его прежнюю ширину.
      Cell.ColumnWidth = WCol1
      'Объединяем все нужные ячейки.
      MRng.MergeCells = True
    End If
  Next nCol
  Next nRow
  
  'Восстанавливаем прежний режим показа предупреждений.
  Application.DisplayAlerts = DispAl
End Sub
 
'Проверка.
Sub Sub1()
  Dim Rng As Excel.Range
  Dim Sh As Excel.Worksheet
  
  Set Sh = Application.ActiveSheet
  Set Rng = Sh.Range("A1:J5")
  
  RngAutoFit Rng
End Sub
Осталось код процедуры RngAutoFit() перевести на Delphi.
---
Идея этого алгоритма такая:
- Замеряем размеры объединённой ячейки.
- Затем, разъединяем диапазон. При этом, весь текст окажется в левой верхней ячейке диапазона объединения.
- Задаём ширину левой верхней ячейки равной ширине исходного объединённого диапазона.
- Выполняем для левой верхней ячейки подгон высоты.
- Затем, сравниваем полученную высоту с исходной высотой всего объединённого диапазона. И если оказалось, что полученная высота больше исходной, тогда на соответствующую величину увеличиваем высоту верхней строки диапазона.
- Вновь объединяем все нужные ячейки.
---
Книга MS Excel с этим кодом приложена к сообщению.
1
Вложения
Тип файла: xls AutoFitForMergeredCells.xls (37.0 Кб, 190 просмотров)
Fistashka
0 / 0 / 0
Регистрация: 02.12.2011
Сообщений: 16
20.12.2011, 21:32  [ТС] 5
Цитата Сообщение от Mawrat Посмотреть сообщение
Если ячейки объединены по нескольким строкам, то тогда неизвестно для каких из этих строк следует подгонять высоту. Ведь это можно сделать разными способами, изменяя высоту той или иной строки, в пределах объединения. Поэтому метод AutoFit не выполняет изменений для объединённых ячеек.
Такую задачу можно решать по-разному в зависимости от особенностей расположения данных на листе. Например, можно принять такое решение: в случае обнаружения объединения ячеек будем подгонять высоту только верхней строки, входящей в объединение. При этом, изменять высоту, если потребуется, будем только в сторону увеличения. Уменьшать высоту не будем, чтобы не нарушить соотношения по уже сделанным ранее объединениям.
По этому условию в VBA у меня получился такой код:
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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Option Explicit
 
'Эта процедура предназначена для подгона высоты строк по содержимому ячеек
'в пределах заданного диапазона aRng.
Sub RngAutoFit(ByRef aRng As Excel.Range)
  Dim Cell As Excel.Range 'Отдельная ячейка.
  Dim MRng As Excel.Range 'Диапазон объединения ячеек.
  Dim DispAl As Boolean
  Dim nRow As Long
  Dim nCol As Long
  Dim HRow1 As Long 'Высота верхней строки в диапазоне объединения.
  Dim H1 As Long 'Исходная высота по совокупности всех строк объединения.
  Dim H2 As Long 'Наименьшая необходимая высота для показа текста в объединённой ячейке.
  Dim WCol1 As Long 'Исходная ширина левого столбца в диапазоне объединения.
  Dim W1 As Long 'Исходная ширина по совокупности всех столбцов объединения.
  Dim i As Long
  
  If aRng Is Nothing Then Exit Sub
  
  'Подгоняем высоту строк для ячеек, которые не входят в диапазоны объединённых ячеек.
  aRng.Rows.AutoFit
  'Отключаем режим показа предупреждений. Это надо для того, чтобы в следующей части
  'программы не появлялось сообщение с предупреждением о последствиях объединения.
  DispAl = Application.DisplayAlerts
  Application.DisplayAlerts = False
  
  'Перебор всех ячеек диапазона.
  For nRow = 1 To aRng.Rows.Count
  For nCol = 1 To aRng.Columns.Count
    'Берём очередную ячейку.
    Set Cell = aRng.Cells(nRow, nCol)
    'Определяем диапазон объединения, в который входит ячейка Cell.
    Set MRng = Cell.MergeArea
    'Если в самом деле ячейка принадлежит диапазону объединённых ячеек и эта ячейка
    'является левой верхней ячейкой в этом диапазоне, тогда запускаем алгоритм подгона высоты.
    If Cell.MergeCells And (Cell = MRng.Cells(1, 1)) Then
      'Высота верхней строки в диапазоне объединения.
      HRow1 = MRng.Rows(1).RowHeight
      'Подсчитываем исходную высоту диапазона объединения по совокупности всех его строк.
      H1 = HRow1
      For i = 2 To MRng.Rows.Count
        H1 = H1 + MRng.Rows(i).RowHeight
      Next i
      'Ширина левого столбца в диапазоне объединения.
      WCol1 = MRng.Columns(1).ColumnWidth
      'Подсчитываем исходную ширину диапазона объединения по совокупности всех его столбцов.
      W1 = WCol1
      For i = 2 To MRng.Columns.Count
        W1 = W1 + MRng.Columns(i).ColumnWidth
      Next i
      'Теперь разъединяем ячейки.
      MRng.MergeCells = False
      'Ширину левого столбца делаем равным исходной ширине всего диапазона объединения.
      Cell.ColumnWidth = W1
      'Задаём режим переноса текста по словам.
      Cell.WrapText = True
      'Выполняем подгон высоты верхней строки.
      Cell.Rows.AutoFit
      'Выполняем замер получившейся высоты верхней строки.
      'Это наименьшая высота, пригодная для показа текста.
      H2 = Cell.Rows(1).RowHeight
      'Если исходная высота диапазона объединения оказалась меньше, чем наименьшая
      'пригодная высота, то увеличиваем высоту верхней строки на соответствующую величину.
      If H1 < H2 Then
        Cell.Rows(1).RowHeight = HRow1 + (H2 - H1)
      End If
      'Возвращаем левому столбцу диапазона его прежнюю ширину.
      Cell.ColumnWidth = WCol1
      'Объединяем все нужные ячейки.
      MRng.MergeCells = True
    End If
  Next nCol
  Next nRow
  
  'Восстанавливаем прежний режим показа предупреждений.
  Application.DisplayAlerts = DispAl
End Sub
 
'Проверка.
Sub Sub1()
  Dim Rng As Excel.Range
  Dim Sh As Excel.Worksheet
  
  Set Sh = Application.ActiveSheet
  Set Rng = Sh.Range("A1:J5")
  
  RngAutoFit Rng
End Sub
Осталось код процедуры RngAutoFit() перевести на Delphi.
---
Идея этого алгоритма такая:
- Замеряем размеры объединённой ячейки.
- Затем, разъединяем диапазон. При этом, весь текст окажется в левой верхней ячейке диапазона объединения.
- Задаём ширину левой верхней ячейки равной ширине исходного объединённого диапазона.
- Выполняем для левой верхней ячейки подгон высоты.
- Затем, сравниваем полученную высоту с исходной высотой всего объединённого диапазона. И если оказалось, что полученная высота больше исходной, тогда на соответствующую величину увеличиваем высоту верхней строки диапазона.
- Вновь объединяем все нужные ячейки.
---
Книга MS Excel с этим кодом приложена к сообщению.
Благодарствую, буду думать ))
0
Mawrat
12880 / 5782 / 1704
Регистрация: 19.09.2009
Сообщений: 8,807
21.12.2011, 16:41 6
Лучший ответ Сообщение было отмечено как решение

Решение

Сделал перевод для Delphi.
Там в коде ещё надо подправить одну строчку.
Заменить:
Visual Basic
1
    If Cell.MergeCells And (Cell = MRng.Cells(1, 1)) Then
на:
Visual Basic
1
    If Cell.MergeCells And (Cell.Address = MRng.Cells(1, 1).Address) Then
Потому что в коде
Visual Basic
1
  If ... (Cell = MRng.Cells(1, 1)) ... Then
на самом деле сравниваются не ссылки на указанные объекты, а сравниваются значения свойств по умолчанию для этих объектов. Так как Cell и MRng.Cells(1, 1) принадлежат типу Excel.Range, то для них свойством по умолчанию будет Value. Т. е. код:
Visual Basic
1
  If ... (Cell = MRng.Cells(1, 1)) ... Then
эквивалентен коду:
Visual Basic
1
  If ... (Cell.Value = MRng.Cells(1, 1).Value) ... Then
А это не то что нам нужно. Нам надо не значение ячеек сравнивать, а выяснить, ссылаются ли эти переменные на одну и ту же ячейку. Для этого было решено использовать свойство Address.
---
Окончательный код VBA:
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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Option Explicit
 
'Эта процедура предназначена для подгона высоты строк по содержимому ячеек в пределах
'заданного диапазона aRng. Ячейки могут быть любыми, в том числе, объединёнными.
Sub RngAutoFit(ByRef aRng As Excel.Range)
  Dim Cell As Excel.Range 'Отдельная ячейка.
  Dim MRng As Excel.Range 'Диапазон объединения ячеек.
  Dim DispAl As Boolean
  Dim nRow As Long
  Dim nCol As Long
  Dim HRow1 As Long 'Высота верхней строки в диапазоне объединения.
  Dim H1 As Long 'Исходная высота по совокупности всех строк объединения.
  Dim H2 As Long 'Наименьшая необходимая высота для показа текста в объединённой ячейке.
  Dim WCol1 As Long 'Исходная ширина левого столбца в диапазоне объединения.
  Dim W1 As Long 'Исходная ширина по совокупности всех столбцов объединения.
  Dim i As Long
  
  If aRng Is Nothing Then Exit Sub
  
  'Подгоняем высоту строк для ячеек, которые не входят в диапазоны объединённых ячеек.
  aRng.Rows.AutoFit
  'Отключаем режим показа предупреждений. Это надо для того, чтобы в следующей части
  'программы не появлялось сообщение с предупреждением о последствиях объединения.
  DispAl = Application.DisplayAlerts
  Application.DisplayAlerts = False
  
  'Перебор всех ячеек диапазона.
  For nRow = 1 To aRng.Rows.Count
  For nCol = 1 To aRng.Columns.Count
    'Берём очередную ячейку.
    Set Cell = aRng.Cells(nRow, nCol)
    'Определяем диапазон объединения, в который входит ячейка Cell.
    Set MRng = Cell.MergeArea
    'Если в самом деле ячейка принадлежит диапазону объединённых ячеек и эта ячейка
    'является левой верхней ячейкой в этом диапазоне, тогда запускаем алгоритм подгона высоты.
    If Cell.MergeCells And (Cell.Address = MRng.Cells(1, 1).Address) Then
      'Высота верхней строки в диапазоне объединения.
      HRow1 = MRng.Rows(1).RowHeight
      'Подсчитываем исходную высоту диапазона объединения по совокупности всех его строк.
      H1 = HRow1
      For i = 2 To MRng.Rows.Count
        H1 = H1 + MRng.Rows(i).RowHeight
      Next i
      'Ширина левого столбца в диапазоне объединения.
      WCol1 = MRng.Columns(1).ColumnWidth
      'Подсчитываем исходную ширину диапазона объединения по совокупности всех его столбцов.
      W1 = WCol1
      For i = 2 To MRng.Columns.Count
        W1 = W1 + MRng.Columns(i).ColumnWidth
      Next i
      'Теперь разъединяем ячейки.
      MRng.MergeCells = False
      'Ширину левого столбца делаем равным исходной ширине всего диапазона объединения.
      Cell.ColumnWidth = W1
      'Задаём режим переноса текста по словам.
      Cell.WrapText = True
      'Выполняем подгон высоты верхней строки.
      Cell.Rows.AutoFit
      'Выполняем замер получившейся высоты верхней строки.
      'Это наименьшая высота, пригодная для показа текста.
      H2 = Cell.Rows(1).RowHeight
      'Если исходная высота диапазона объединения оказалась меньше, чем наименьшая
      'пригодная высота, то увеличиваем высоту верхней строки на соответствующую величину.
      If H1 < H2 Then
        Cell.Rows(1).RowHeight = HRow1 + (H2 - H1)
      End If
      'Возвращаем левому столбцу диапазона его прежнюю ширину.
      Cell.ColumnWidth = WCol1
      'Объединяем все нужные ячейки.
      MRng.MergeCells = True
    End If
  Next nCol
  Next nRow
  
  'Восстанавливаем прежний режим показа предупреждений.
  Application.DisplayAlerts = DispAl
End Sub
 
'Проверка.
Sub Sub1()
  Dim Rng As Excel.Range
  Dim Sh As Excel.Worksheet
  
  Set Sh = Application.ActiveSheet
  Set Rng = Sh.Range("A1:J5")
  
  RngAutoFit Rng
End Sub
Код Delphi:
Delphi
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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
uses
  ComObj;
 
//Эта процедура предназначена для подгона высоты строк по содержимому ячеек в пределах
//заданного диапазона aRng. Ячейки могут быть любыми, в том числе, объединёнными.
procedure RngAutoFit(var aRng : Variant);
var
  //Cell - Отдельная ячейка, MRng - диапазон объединения ячеек.
  Cell, MRng : Variant;
  DispAl : Boolean;
  nRow, nCol,
  HRow1, //Высота верхней строки в диапазоне объединения.
  H1,    //Исходная высота по совокупности всех строк объединения.
  H2,    //Наименьшая необходимая высота для показа текста в объединённой ячейке.
  WCol1, //Исходная ширина левого столбца в диапазоне объединения.
  W1,    //Исходная ширина по совокупности всех столбцов объединения.
  i : Integer;
begin
  //В VBA это: if aRng is Nothing then Exit Sub
  if TVarData(aRng).VDispatch = nil then Exit;
 
  //Подгоняем высоту строк для ячеек, которые не входят в диапазоны объединённых ячеек.
  aRng.Rows.AutoFit;
  //Отключаем режим показа предупреждений. Это надо для того, чтобы в следующей части
  //программы не появлялось сообщение с предупреждением о последствиях объединения.
  DispAl := aRng.Application.DisplayAlerts;
  aRng.Application.DisplayAlerts := False;
 
  //Перебор всех ячеек диапазона.
  for nRow := 1 to aRng.Rows.Count do
  for nCol := 1 to aRng.Columns.Count do begin
    //Берём очередную ячейку.
    Cell := aRng.Cells[nRow, nCol];
    //Определяем диапазон объединения, в который входит ячейка Cell.
    MRng := Cell.MergeArea;
    //Если в самом деле ячейка принадлежит диапазону объединённых ячеек и эта ячейка
    //является левой верхней ячейкой в этом диапазоне, тогда запускаем алгоритм подгона высоты.
    //Иначе - пропускаем итерацию.
    if not ( Cell.MergeCells and (Cell.Address = MRng.Cells[1, 1].Address) ) then Continue;
 
    //Высота верхней строки в диапазоне объединения.
    HRow1 := MRng.Rows[1].RowHeight;
    //Подсчитываем исходную высоту диапазона объединения по совокупности всех его строк.
    H1 := HRow1;
    for i := 2 to MRng.Rows.Count do
      H1 := H1 + MRng.Rows[i].RowHeight
    ;
    //Ширина левого столбца в диапазоне объединения.
    WCol1 := MRng.Columns[1].ColumnWidth;
    //Подсчитываем исходную ширину диапазона объединения по совокупности всех его столбцов.
    W1 := WCol1;
    for i := 2 to MRng.Columns.Count do
      W1 := W1 + MRng.Columns[i].ColumnWidth
    ;
    //Теперь разъединяем ячейки.
    MRng.MergeCells := False;
    //Ширину левого столбца делаем равным исходной ширине всего диапазона объединения.
    Cell.ColumnWidth := W1;
    //Задаём режим переноса текста по словам.
    Cell.WrapText := True;
    //Выполняем подгон высоты верхней строки.
    Cell.Rows.AutoFit;
    //Выполняем замер получившейся высоты верхней строки.
    //Это наименьшая высота, пригодная для показа текста.
    H2 := Cell.Rows[1].RowHeight;
    //Если исходная высота диапазона объединения оказалась меньше, чем наименьшая
    //пригодная высота, то увеличиваем высоту верхней строки на соответствующую величину.
    if H1 < H2 then
      Cell.Rows[1].RowHeight := HRow1 + (H2 - H1)
    ;
    //Возвращаем левому столбцу диапазона его прежнюю ширину.
    Cell.ColumnWidth := WCol1;
    //Объединяем все нужные ячейки.
    MRng.MergeCells := True;
  end; //for nRow, nCol.
 
  //Восстанавливаем прежний режим показа предупреждений.
  aRng.Application.DisplayAlerts := DispAl;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  App, Book, Sh, Rng : Variant;
  Od : TOpenDialog;
begin
  Od := OpenDialog1;
  if Od.InitialDir = '' then
    Od.InitialDir := ExtractFilePath( ParamStr(0) )
  ;
  if not Od.Execute then Exit;
  if not FileExists(Od.FileName) then begin
    MessageBox(
      0
      ,PChar('Файл с заданным именем не найден. Действие отменено.')
      ,PChar('Предупреждение.')
      ,MB_OK + MB_ICONWARNING + MB_APPLMODAL
    );
    Exit;
  end;
 
  App := CreateOleObject('Excel.Application');
  App.Visible := True;
  Book := App.Workbooks.Open(Od.FileName);
  //Первый лист в рабочей книге.
  Sh := Book.Worksheets[1];
  //Весь используемый диапазон ячеек на листе.
  Rng := Sh.UsedRange;
 
  //Если требуется повысить скорость работы, следует отключить
  //режим перерисовки экрана. Но после обработки надо не забыть
  //этот режим включить вновь - чтобы пользователь мог работать
  //с открытой книгой.
  //App.ScreenUpdating := False;
 
  //Подгон высоты строк по всем ячейкам, включая объединённые.
  RngAutoFit(Rng);
 
  //Включаем обновление экрана в Excel.
  //App.ScreenUpdating := True;
end;
В приложенном архиве проект Delphi и книга Excel с проектом VBA.
3
Вложения
Тип файла: rar AutoFitWithMergeredCells.rar (186.1 Кб, 222 просмотров)
Fistashka
0 / 0 / 0
Регистрация: 02.12.2011
Сообщений: 16
21.12.2011, 18:30  [ТС] 7
Спасибо Вам огромное, сама бы я никогда до этого не додумалась )) Вы меня просто спасли ))
 Комментарий модератора 
Пожалуйста.
0
21.12.2011, 18:30
Answers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
21.12.2011, 18:30

Макрос для Excel - изменение ячеек по шаблону
Добрый день! Просьба помочь - нужен макрос со следующим условием: В ячейку А1 я вношу слово...

Указать тип ячеек для экспорта в Excel
hi ! делаю экспорт данных, вроде все отлично. Но после экспорта в Excel тип ячеек не...

Выполнение макроса для всех ячеек столбца Excel
Здравствуйте! Мне нужно сделать так что бы макрос выполнялся для всех ячеек столбца. Этот пример...


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

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

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2020, vBulletin Solutions, Inc.