Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Вставка разрывов страниц по условию
 
#1
29.04.2015 17:16:38
В моем примере необходимо вставлять вертикальный разрыв страницы на следующих условиях:
Если в полях проверки стоят "графика" и "номер" то разрыв перемещаем до текста выше. Текстовых строк может быть от 0 и более между графикой. Графика всегда 8 строк.
Предполагается что данных много, выполнять надо в цикле как я понимаю...
Изменено: Sla_0412 - 19.03.2020 19:01:14
 
 
 
#2
29.04.2015 20:06:04
Цитата
как я понимаю...
А я, так понимаю, что нужен горизонтальный разрыв
 
 
 
#3
29.04.2015 20:07:33
да, мне нужно только по горизонтали
 
 
 
#4
29.04.2015 20:08:54
И еще, сколько строк умещается на странице?
Используйте
Цитата
ActiveSheet.HPageBreaks.Add ячейка
разрыв над ячейкой
Изменено: Kuzmich - 05.05.2015 14:55:22
 
 
 
#5
29.04.2015 20:23:06
Проблема состоит в том что при использовании ActiveSheet.HPageBreaks.Add ячейка, я смог только сдвинуть первый разрыв, который влияет на последующие разрывы ниже по строкам. те никак не соображу как зациклить обработку если информация всегда размещается вразнобой.(листов множество и комбинации текста и графики разные)
 
 
 
#6
29.04.2015 21:30:53
Попробуйте так
Код
Sub Razdel_31()
Dim i As Long
Dim iLastRow As Long
Dim iPage As Long
    iLastRow = Cells(Rows.Count, 4).End(xlUp).Row
      iPage = 1
  For i = 1 To iLastRow
    Do
      If Cells(i, 5) = "графика" Then
        If i + 7 >= 32 * iPage Then Exit Do
        i = i + 8
      Else
        If i + 1 >= 32 * iPage Then Exit Do
        i = i + 1
      End If
    Loop While i < 32 * iPage
        ActiveSheet.HPageBreaks.Add Cells(i + 1, 1)
      iPage = iPage + 1
  Next
End Sub
 
 
 
#7
29.04.2015 21:52:52
Я может как то неправильно описал задачу, но во первых, файл выложен как пример и привязываться к его размерам высоты строк а так же к ориентации листа никак нельзя. Предполагается использовать метод для разных целей (отчеты разных документов) , на разных компьютерах, с разными принтерами. Во-вторых , он даже в том виде в котором есть, не отрабатывает  свою задачу.(Это легко проверить скопировав текст примера вниз и продолжив ряд строк.
Я вижу алгоритм так: находим первый разрыв, смещаем его на n количество строк вверх до текста. Далее повторяем задачу до конца. Фишка в том что при смещении первого разрыва, остальные "переходят" тоже вверх.
 
 
 
#8
29.04.2015 23:01:43
Цитата
Sla_0412 написал: Фишка в том что при смещении первого разрыва, остальные "переходят" тоже вверх.
И?
По по очереди проверяем все разрывы, если нужно - двигаем.
 
 
 
#9
29.04.2015 23:09:21
Попробуйте так
Код
Sub Razdel_31()
Dim i As Long
Dim iLastRow As Long
Dim iPage As Long
Dim iHPBreak As HPageBreak
Dim KolStrok As Long
   For Each iHPBreak In ActiveSheet.HPageBreaks
    iHPBreak.Delete
   Next
  KolStrok = ActiveSheet.HPageBreaks(1).Location.Row - 1
    iLastRow = Cells(Rows.Count, 4).End(xlUp).Row
      iPage = 1
  For i = 1 To iLastRow
    Do
      If Cells(i, 5) = "графика" Then
        If i + 8 >= KolStrok * iPage Then Exit Do
        i = i + 8
      Else
        If i + 1 >= KolStrok * iPage Then Exit Do
        i = i + 1
      End If
    Loop While i <= KolStrok * iPage
        ActiveSheet.HPageBreaks.Add Cells(i, 1)
      iPage = iPage + 1
  Next
End Sub
 
 
 
#10
30.04.2015 10:29:28
Все работает, но нужно вставить между строкой 6 и 7 On Error Resume Next.
Выражаю огромную благодарность Kuzmich.
 
 
 
#11
02.06.2015 11:41:47
Здравствуйте! У меня вопрос по этой теме. мне надо поставить разрыв перед словом "карточка" (т.е. каждая карточка должна начинаться с новой страницы при печати).
предыдущий макрос у меня почему-то не сработал, наверное там надо что-то поменять, кроме слова графика?
помогите пожалуйста.
 
 
 
#12
02.06.2015 12:49:00
Попробуйте так Параметры страницы - Поля верхнее 1, нижнее - 1,5 колонтитулы - 0
Код
Sub Razdel_31()
Dim i As Long
Dim iLastRow As Long
Dim iPage As Long
Dim iHPBreak As HPageBreak
Dim KolStrok As Long
    On Error Resume Next
   For Each iHPBreak In ActiveSheet.HPageBreaks
    iHPBreak.Delete
   Next
  KolStrok = ActiveSheet.HPageBreaks(1).Location.Row - 1
    iLastRow = Cells(Rows.Count, 34).End(xlUp).Row
      iPage = 1
  For i = 2 To iLastRow
    Do
      If Cells(i, 21) = "КАРТОЧКА" Then
        If i + 60 >= KolStrok * iPage Then Exit Do
        i = i + 60
      Else
        If i + 1 >= KolStrok * iPage Then Exit Do
        i = i + 1
      End If
    Loop While i <= KolStrok * iPage
        ActiveSheet.HPageBreaks.Add Cells(i, 1)
      iPage = iPage + 1
  Next
End Sub
 
 
 
#13
02.06.2015 12:55:21
Kuzmich, спасибо, работает!!!
 
 
 
#14
02.06.2015 18:23:24
захотела сама подогнать макрос под другой файл... видно не дано..... посмотрите, что не так?
Код
Sub Razdel_31()
Dim i As Long
Dim iLastRow As Long
Dim iPage As Long
Dim iHPBreak As HPageBreak
Dim KolStrok As Long
    On Error Resume Next
   For Each iHPBreak In ActiveSheet.HPageBreaks
    iHPBreak.Delete
   Next
  KolStrok = ActiveSheet.HPageBreaks(1).Location.Row - 1
    iLastRow = Cells(Rows.Count, 130).End(xlUp).Row
      iPage = 1
  For i = 2 To iLastRow
    Do
      If Cells(i, 1) = "Расчетный листок за Май 2015" Then
        If i + 25 >= KolStrok * iPage Then Exit Do
        i = i + 25
      Else
        If i + 1 >= KolStrok * iPage Then Exit Do
        i = i + 1
      End If
    Loop While i <= KolStrok * iPage
        ActiveSheet.HPageBreaks.Add Cells(i, 1)
      iPage = iPage + 1
  Next
End Sub
 
 
 
#15
02.06.2015 19:44:22
Макрос попроще
Код
Sub q()
    Dim r As Range
    Set r = Cells.Find(What:="Расчетный листок", LookAt:=xlPart)
    If Not r Is Nothing Then
        Do
            If r Is Nothing Or r.Row = 1 Then Exit Do
            ActiveSheet.HPageBreaks.Add r
            Set r = Cells.FindNext(r)
        Loop
    End If
End Sub
 
 
 
#16
02.06.2015 20:26:06
Цитата
посмотрите, что не так?
В 130 столбце нет данных, ищите последнюю строку по первому столбцу
Код
 iLastRow = Cells(Rows.Count, 130).End(xlUp).Row
 
 
 
#17
04.06.2015 10:52:56
RAN, спасибо большое, работает
Kuzmich, поняла, спасибо

ВЫ ГЕНИИ!!!!!
 
 
 
#18
16.05.2019 12:47:23
Ребята, помогите, плиз прописать макрос. У самой ничего не получается. В табличке, которая прикреплена,  нужен разрыв страницы по первой колонке "ветка". И чтобы на одной страничке было только 23 строки.
Буду очень благодарна за помощь
 
 
 
#19
19.03.2020 17:48:19
Цитата
RAN написал:
Макрос попроще
Добрый день.
Подскажите, пожалуйста, какие изменения нужно внести в Ваш макрос, чтобы разрывы проставлялись каждые N строк (например, каждые 30 строк)?
 
 
 
#20
20.03.2020 13:35:29
Цитата
чтобы на одной страничке было только 23 строки.
Код
Sub ВставитьРазрыв()   
Dim i As Long
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  ActiveSheet.ResetAllPageBreaks
    i = 24
 Do While i < iLastRow
    ActiveSheet.HPageBreaks.Add ActiveSheet.Range("A" & i)
    i = i + 23
 Loop
End Sub
Изменено: Kuzmich - 20.03.2020 14:58:53
 
 
 
#21
20.03.2020 14:12:24
Спасибо Kuzmich, я это тоже искал!
 
 
 
#22
21.10.2020 13:34:43
Здравствуйте, уважаемые!

Если можете, помогите, пожалуйста, с похожей задачей.

Есть стандартная накладная в которой есть шапка накладной, тело (таблица с товарами), а так же подписи.
При печати документа бывает так, что подпись (или ее часть) отрываются от основной части таблицы.
Параметры печати: вписать все столбцы на одном листе. Все поля по 0,8 см. Колонтитулы по 0 см.

Можно ли проверить находятся начало подписи и конец на одном листе и, если да, то проверить не оторвана ли подпись от основной таблицы? И в зависимости от сложности реализации или уменьшить на 1 выводимые на печать количество страниц или добавить разрыв перед последней строкой табличной части?

Визуально можно посмотреть в прилагаемом файле.
Изменено: Vitalio - 21.10.2020 13:35:13 (Добавил файл)
 
 
 
Страницы: 1
Читают тему
Наверх