Расстановка разрывов на листе во всей книге по условию - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/Расстановка разрывов на листе во всей книге по условию - Мир MS Excel

Старая форма входа

Страница 1 из 2 1 2 »
Модератор форума: китин, _Boroda_

Расстановка разрывов на листе во всей книге по условию (Макросы/Sub)

Расстановка разрывов на листе во всей книге по условию

Дата: Пятница, 07.02.2020, 08:03 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Здравствуйте.
Есть excel книга. В ней много листов , порядка 350.
Каждый лист содержит 3 формы, которые нужно распечатать на отдельном листе.
Автоматом расстановка разрывов криво встает.
Макросом Нужно разбить на 3 страницы каждый лист, ставя разрыв в определенном месте. Допустим где стоит условный знак.

И макрос должен отработать всю книгу, порядка 350 листов.

Помогите пожалуйста.

Пример во вложении

К сообщению приложен файл: 3346378.xlsx (208.1 Kb)

Ответить

Дата: Пятница, 07.02.2020, 11:22 | Сообщение № 2

Группа: Проверенные

Ранг: Ветеран

Сообщений: 713

Репутация: 157 ±

Замечаний: 0% ±

Excel 2003

Макросом.
Нашли все ячейки с условными знаками в цикле Find.....FindNext
Пусть это будет ячейка(Объект) FoundSymbol
Добавляете горизонтальный разрыв над этой ячейкой (sh-активный лист)
[vba]

Код

sh.HPageBreaks.Add Before:=sh.Rows(FoundNomer.Row)

[/vba]

Ответить

Дата: Пятница, 07.02.2020, 11:32 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Kuzmich, а можно полностью макрос, просто я начинающий в этом деле)

Ответить

Дата: Пятница, 07.02.2020, 11:34 | Сообщение № 4

Группа: Проверенные

Ранг: Ветеран

Сообщений: 713

Репутация: 157 ±

Замечаний: 0% ±

Excel 2003

Посмотрите на соседнем форуме
https://www.planetaexcel.ru/forum....=125276

Ответить

Дата: Пятница, 07.02.2020, 11:56 | Сообщение № 5

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

[vba]

Код

Sub InsPageBreaks()
  Const Hd$ = "Форма 05*"
  Dim pb&, r&, br&
  With ActiveSheet.HPageBreaks
    Cells(Rows.Count, 1).End(xlUp).Select
    For pb = .Count To 1 Step -1
      If .Item(pb).Type = xlPageBreakManual Then .Item(pb).Delete
    Next
    pb = 1
    Do While pb < .Count
      br = .Item(pb).Location.Row
      If Not Cells(br, 1) Like Hd Then
        r = Cells.Find(Hd, Cells(br, 1), SearchDirection:=xlNext).Row
        If r - br > 2 Then .Add before:=Rows(Cells.Find(Hd, _
          Cells(br, 1), SearchDirection:=xlPrevious).Row)
      End If
      pb = pb + 1
    Loop
  End With
End Sub

[/vba]

Попробовал данный макрос, он отрабатывает только на активном листе, и только один разрыв ставит. У меня на листе 2 разрыва будет. В двух местах ключевое слово есть Const Hd$ = "Форма 05*"

Надо на всей книге ,в которой порядка 350 листов.

Сообщение отредактировал minister - Пятница, 07.02.2020, 11:56

Ответить

Дата: Пятница, 07.02.2020, 12:02 | Сообщение № 6

Группа: Проверенные

Ранг: Ветеран

Сообщений: 713

Репутация: 157 ±

Замечаний: 0% ±

Excel 2003

minister
Вы можете выложить ваш пример в формате .xls
ваш файл из первого сообщения конвертер не воспринимает.

Цитата

Надо на всей книге ,в которой порядка 350 листов

Надо сделать цикл по всем листам

Ответить

Дата: Пятница, 07.02.2020, 12:11 | Сообщение № 7

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Прикрепил

К сообщению приложен файл: __.xls (207.0 Kb)

Ответить

Дата: Пятница, 07.02.2020, 12:29 | Сообщение № 8

Группа: Проверенные

Ранг: Ветеран

Сообщений: 713

Репутация: 157 ±

Замечаний: 0% ±

Excel 2003

А где на листах ячейка с "Форма 05*" ?

Ответить

Дата: Пятница, 07.02.2020, 12:32 | Сообщение № 9

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

В образце это место обозвал "новая страничка"
Над этим поле разрыв. Получается 3 формы, на каждом листе отдельно

Ответить

Дата: Пятница, 07.02.2020, 12:38 | Сообщение № 10

Группа: Проверенные

Ранг: Ветеран

Сообщений: 713

Репутация: 157 ±

Замечаний: 0% ±

Excel 2003

Первая страница FX:GW в пределах страницы
остальные сдвинуты GE:HC и выходят за границы страницы?

Ответить

Дата: Пятница, 07.02.2020, 12:44 | Сообщение № 11

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Да, первая страничка на листе поуже, остальные две одинаковые по ширине,

Но можно и по одной ширине все печатать

Ответить

Дата: Пятница, 07.02.2020, 14:22 | Сообщение № 12

Группа: Проверенные

Ранг: Ветеран

Сообщений: 713

Репутация: 157 ±

Замечаний: 0% ±

Excel 2003

Макрос для одного листа
[vba]

Код

Sub Вставить_разрывы()
Dim sh As Worksheet
Dim FoundStr As Range
Dim FAdr As String
Application.ScreenUpdating = False
  Set sh = ActiveSheet
  With sh
    .PageSetup.PrintArea = "$A:$GW"
    .ResetAllPageBreaks
    .PageSetup.Zoom = False
    .PageSetup.FitToPagesWide = 1
    .PageSetup.FitToPagesTall = False
    Set FoundStr = .Columns("GE:HC").Find("новая страничка", , xlValues, xlWhole)
     If Not FoundStr Is Nothing Then
       FAdr = FoundStr.Address
      Do
        Set FoundStr = .Columns("GE:HC").FindNext(FoundStr)
        .HPageBreaks.Add Before:=sh.Rows(FoundStr.Row)
      Loop While FoundStr.Address <> FAdr
     End If
  End With
Application.ScreenUpdating = True
    MsgBox "Разрывы вставлены!", vbInformation
End Sub

[/vba]
Цикл по всем листам сделайте сами.

Ответить

Дата: Пятница, 07.02.2020, 15:59 | Сообщение № 13

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Цитата Kuzmich, 07.02.2020 в 14:22, в сообщении № 12 ()

.PageSetup.PrintArea = "$A:$GW"

Спасибо работает.

Только режет по уровню первой странички все остальные листы, поправил .PageSetup.PrintArea = "$A:$GW" на .PageSetup.PrintArea = "$A:$HC"

Попробую цикл сделать, нагуглю поди))

Сообщение отредактировал minister - Пятница, 07.02.2020, 16:03

Ответить

Дата: Пятница, 07.02.2020, 16:59 | Сообщение № 14

Группа: Проверенные

Ранг: Ветеран

Сообщений: 713

Репутация: 157 ±

Замечаний: 0% ±

Excel 2003

Используйте цикл по всем листам книги
[vba]

Код

Dim Sht As Worksheet
    For Each Sht In Worksheets
    .............
    Next

[/vba]

Ответить

Дата: Суббота, 08.02.2020, 13:17 | Сообщение № 15

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

[vba]

Код

Sub Вставить_разрывы()
Dim Sht As Worksheet
    For Each Sht In Worksheets

Dim FoundStr As Range
Dim FAdr As String
Application.ScreenUpdating = False
Set sh = ActiveSheet
With sh
    .PageSetup.PrintArea = "$A:$HC"
    .ResetAllPageBreaks
    .PageSetup.Zoom = False
    .PageSetup.FitToPagesWide = 1
    .PageSetup.FitToPagesTall = False
    Set FoundStr = .Columns("GE:HC").Find("новая страничка", , xlValues, xlWhole)
    If Not FoundStr Is Nothing Then
    FAdr = FoundStr.Address
    Do
        Set FoundStr = .Columns("GE:HC").FindNext(FoundStr)
        .HPageBreaks.Add Before:=sh.Rows(FoundStr.Row)
    Loop While FoundStr.Address <> FAdr
    End If
End With
Application.ScreenUpdating = True
    MsgBox "Разрывы вставлены!", vbInformation
Next
End Sub

[/vba]

Получился такой код, но почему то на активном листе отрабатывает. Но Сообщение что разрыв вставлен выскакивает 3 раза (жму ок)

Кстати, чтоб 350 раз ОК не жать нужно удалить это ?
[vba]

Код

Application.ScreenUpdating = True
MsgBox "Разрывы вставлены!", vbInformation

[/vba]

Ответить

Дата: Суббота, 08.02.2020, 13:20 | Сообщение № 16

Группа: Друзья

Ранг: Экселист

Сообщений: 9005

Репутация: 2369 ±

Замечаний: 0% ±

Excel 2010

уберите под Next

ЮMoney 41001841029809

Ответить

Дата: Суббота, 08.02.2020, 13:25 | Сообщение № 17

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Цитата Nic70y, 08.02.2020 в 13:20, в сообщении № 16 ()

уберите под Next

тоесть End Sub ? тогда ошибка.

Надо чтоб макрос по всем 350 листам проходил, с одного нажатия.

Ответить

Дата: Суббота, 08.02.2020, 13:28 | Сообщение № 18

Группа: Админы

Ранг: Местный житель

Сообщений: 19405

Репутация: 4555 ±

Замечаний: ±

Excel 365 & Mac Excel

Цитата minister, 08.02.2020 в 13:17, в сообщении № 15 ()

на активном листе отрабатывает

строчку [vba]

Код

For Each sh In Worksheets

[/vba] вставьте ВМЕСТО [vba]

Код

Set sh = ActiveSheet

[/vba] обратите внимание на имена переменных

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Суббота, 08.02.2020, 13:31 | Сообщение № 19

Группа: Друзья

Ранг: Экселист

Сообщений: 9005

Репутация: 2369 ±

Замечаний: 0% ±

Excel 2010

[vba]

Код

End With
Next
Application.ScreenUpdating = True
MsgBox "Разрывы вставлены!", vbInformation
End Sub

[/vba]

ЮMoney 41001841029809

Ответить

Дата: Суббота, 08.02.2020, 13:35 | Сообщение № 20

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Всем огромное спасибо, кажется заработало. По край не мере на тестовом файле.
В понедельник буду на рабочем тестить.

итоговый код
[vba]

Код

Sub Вставить_разрывы()
Dim sh As Worksheet
Dim FoundStr As Range
Dim FAdr As String
Application.ScreenUpdating = False
For Each sh In Worksheets
With sh
    .PageSetup.PrintArea = "$A:$HC"
    .ResetAllPageBreaks
    .PageSetup.Zoom = False
    .PageSetup.FitToPagesWide = 1
    .PageSetup.FitToPagesTall = False
    Set FoundStr = .Columns("GE:HC").Find("новая страничка", , xlValues, xlWhole)
    If Not FoundStr Is Nothing Then
    FAdr = FoundStr.Address
    Do
        Set FoundStr = .Columns("GE:HC").FindNext(FoundStr)
        .HPageBreaks.Add Before:=sh.Rows(FoundStr.Row)
    Loop While FoundStr.Address <> FAdr
    End If
End With
Next
End Sub

[/vba]

Ответить

Расстановка разрывов на листе во всей книге по условию (Макросы/Sub)

Страница 1 из 2
1
2
»

© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!