перенос объединенных ячеек

[ewe007]

P.S. Забыл сказать - перед запуском макроса необходимо отобразить разбиение на страницы. Это можно сделать и макросом первой строкой - ActiveSheet.DisplayPageBreaks = True

спасибо
но почему-то если документ в обычном виде все происходит раза в 3 быстрее, чем в режиме "просмотра страницы"
даже скорее можно сказать, что в режиме просмотра это занимает неприлично много времени, уже думал что повис)

[Дмитрий Щербаков(The_Prist)]

Тут дело такое, что хотя бы удостоверьтесь потом, что правильно все перенеслось. А думать, да - будет дольше в этом режиме.

[Alex_ST]

Дмитрий,
решение интересное и, бывает, действительно нужное.
Ведь в Excel'e в отличие от Word'a нет настройки таблицы "не разбивать ячейку при переносе на другую страницу" (за точность названия не ручаюсь, но как-то так по смыслу).
Только вот почему необходимо ограничиваться одним столбцом? Может все ячейки строки в UsedRange имеет смысл просматривать?

[Дмитрий Щербаков(The_Prist)]

Алексей - я не претендовал на полностью отработанное решение. Я лишь показал принцип. Если будет время - добью до "универсального" этот код.

[YuriF]

Что касаемо самой проблемы: не так проста, как кажется. С разгону не подъедешь.
Но вот такой вариант предложить могу:

Код Выделить Развернуть

Sub Make_Pages_Breack()
   Dim rUsRng As Range, li As Long, lCnt As Long
   Set rUsRng = Range("A1", Cells.SpecialCells(11))
   For li = 1 To rUsRng.Rows.Count
       If rUsRng.Rows(li).PageBreak <> xlNone Then
           If rUsRng.Cells(li, 1).MergeCells Then
           lCnt = li - Cells(li, 1).MergeArea.Row
               If lCnt > 0 Then Rows(li - lCnt).Resize(lCnt).Insert: lCnt = 0
           End If
       End If
   Next li
End SubПодгонит разрывы так, чтобы объединенные ячейки не "разрывались". Сразу оговорюсь - проверяет объединенные ячейки только в первом столбце.

Димитрий,
первым делом, спасибо за код.
А можно его оптимизировать? Отключение и включение нижепреведенных апликаций не сильно ускоряет процесс.

Код Выделить Развернуть


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

[YuriF]

У меня с таким кодом работает быстрее

[spoiler]

Код (vb) Выделить Развернуть


Private Sub()
Dim sh As Worksheet
Dim NextPageBreakNumber As Long
Dim PageBreakFirstLine  As Object
Dim LineNumber As Long
Set sh = ThisWorkbook.ActiveSheet
ActiveWindow.View = xlPageBreakPreview
sh.ResetAllPageBreaks
NextPageBreakNumber = 1
While NextPageBreakNumber <= sh.HPageBreaks.Count
   Set PageBreakFirstLine = sh.HPageBreaks(NextPageBreakNumber).Location
   LineNumber = PageBreakFirstLine.Row
   If sh.Cells(LineNumber, 1).MergeCells = True Then
       Set sh.HPageBreaks(NextPageBreakNumber).Location = sh.Cells(sh.Cells(LineNumber, 1).MergeArea.Row, 1)
   End If
   NextPageBreakNumber = NextPageBreakNumber + 1
Wend
End Sub
[/spoiler]

[Alex_ST]

с таким кодом

Грамотно (кроме Private Sub(), конечно )!
В первый раз вижу работу с коллекцией HPageBreaks. Надо взять на заметку. Вдруг пригодится.
А по поводу кода, то для удобства пользователя хорошо бы сначала запоминать в дополнительной Integer-переменной текущий вид (их всего 2 возможно: xlNormalView := 1 и xlPageBreakPreview := 2), а после отработки макроса восстанавливать его.

[Дмитрий Щербаков(The_Prist)]

В первый раз вижу работу с коллекцией HPageBreaks

может потому, что она не всегда правильно перестраивается после назначения новых разрывов?

[Alex_ST]

она не всегда правильно перестраивается после назначения новых разрывов

Не знаю, не пробовал.
Т.е. даже метод sh.ResetAllPageBreaks не уверенно помогает?

[Дмитрий Щербаков(The_Prist)]

метод sh.ResetAllPageBreaks не уверенно помогает

он помогает. но ведь после него идет переопределение при помощи Location - вот тут могут начаться глюки. А могу и не начаться.

[Alex_ST]

А могу и не начаться.

Спасибо. Учтём если вдруг придётся использовать (и склероз не помешает)