Страницы: 1
RSS
Ускорить код по применению параметров страницы ко всем листам книги
 
Здравствуйте, уважаемые форумчане!
Перебираю циклом каждый лист в книге и задаю параметры страницы.
В книге порядка 300 листов. Когда применяю макрос, Excel зависает в связи с переполнением памяти.
Подскажите, пожалуйста, как можно ускорить макрос?
Код
Sub Параметры()
For Each xWorksheet In ActiveWorkbook.Worksheets
    With xWorksheet.PageSetup
        .FitToPagesWide = 1
        .Orientation = xlLandscape
        .LeftMargin = Application.InchesToPoints(0.196850393700787)
        .RightMargin = Application.InchesToPoints(0.196850393700787)
        .TopMargin = Application.InchesToPoints(0.196850393700787)
        .BottomMargin = Application.InchesToPoints(0.196850393700787)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .CenterHorizontally = True
        .PrintTitleRows = "$5:$7"
    End With
Next xWorksheet
End Sub
Изменено: Leojse - 12.05.2020 23:39:11
 
Цитата
как можно ускорить макрос?
Сгруппировать листы и установить параметры страницы
 
Здравствуйте. А попробуйте не перебором, а выделить все нужные листы и задать им параметры. Возможно так не все параметры можно задать, а может и получится. А возможно в связи с изменением параметров, что то происходит на листах, пересчитываются какие нибудь формулы. Попробуйте выключить ненужные процедуры на время выполнения этого макроса.
Изменено: gling - 12.05.2020 23:55:51
 
Kuzmich, gling спасибо за подсказки!
 
Сначала сгруппировал листы, затем применил параметры.
Но дело в том, что почему-то не задаются сквозные строки.
Подскажите, пожалуйста, что не так в коде?
Код
Sub листы()
Dim s()
k = Sheets.Count
ReDim s(5 To k)
 
For i = 5 To k
s(i) = i
Next
Sheets(s).Select

Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1000
        .Orientation = xlLandscape
        .LeftMargin = Application.InchesToPoints(0.196850393700787)
        .RightMargin = Application.InchesToPoints(0.196850393700787)
        .TopMargin = Application.InchesToPoints(0.196850393700787)
        .BottomMargin = Application.InchesToPoints(0.196850393700787)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .CenterHorizontally = True
        .PrintTitleRows = "$5:$7"
    End With

Application.PrintCommunication = True
Sheets("Лист1").Select
End Sub
 
Добрый день! Да, есть такой баг, связанный с PrintTitleRows, начиная с версии 2007.
Попробуйте этой свойство присвоить отдельным циклом (перед строкой 27 из #5).
Код
For i = 5 To k
  Sheets(i).PageSetup.PrintTitleRows = "$5:$7"
Next
Не элегантно, конечно, по может помочь.
Владимир
 
sokol92, спасибо! Ваш совет помог!
Страницы: 1
Наверх