Здравствуйте.
Есть код, задающий параметры печати для файлов в папке (я его применяю для файлов *.xls):
Работает он так: я запускаю код, в открывшемся окне выбираю папку, в следующем окне пишу "xls"(без кавычек, конечно), и код задаёт параметры печати - книжную ориентацию и умещение на одной странице - во всех найденных xls-файлах. Вот только делает он это очень медленно. Скажите, пожалуйста, можно ли его как-то ускорить?
Есть код, задающий параметры печати для файлов в папке (я его применяю для файлов *.xls):
Код |
---|
Option Explicit Private Function GetValue(path, file, sheet, ref) Dim arg As String If Right(path, 1) <> "\" Then path = path & "\" If Dir(path & file) = "" Then GetValue = "Файл не найден" Exit Function End If arg = "'" & path & "[" & file & "]" & sheet & "'!" & _ Range(ref).Range("A1").Address(, , xlR1C1) GetValue = ExecuteExcel4Macro(arg) End Function Sub Найти_документы() Const AddrresCell = 4 Dim p As String 'Директория файлов Dim f As String 'Имя файла Dim s As String 'Имя листа Dim a As String 'Адрес ячейки Dim Rng As Range, Sht As Worksheet Dim i&, g&, h&, y& Dim PName As String, FName As String, FQuant As Long, N As Long, d As String, WB As Workbook, firstAddress As String Dim SkolkoNashol As Long Dim SumFlag As Long Dim TWB As Workbook Set TWB = ThisWorkbook 'Вызываем диалоговое окно для определения папки с файлами With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = Application.DefaultFilePath & "\" .Title = "Укажите папку, в которой находятся файлы" .Show If .SelectedItems.Count = 0 Then MsgBox "Отменено" 'Прекращение работы Exit Sub Else PName = .SelectedItems(1) 'Получение пути 'Считаем количество файлов в папке для создания массива названий файлов FName = Dir(PName & "\*.xls") 'Получаем имя первого файла FQuant = 0 'обнуляем кол-во файлов ' Цикл подсчета кол-ва файлов Do Until FName = "" 'Пока имя файла не станет пустым FQuant = FQuant + 1 'Счетчик кол-ва FName = Dir 'Получение следующего имени файла Loop 'Заполняем массив названиями файлов ReDim arr(1 To FQuant) As String 'Задание размерности массива на основе кол-ва файлов FName = Dir(PName & "\*.xls") 'Получаем имя первого файла N = 0 'обнуляем счетчик ' Цикл заполнения массива именами файлов Do Until FName = "" 'Пока имя файла не станет пустым N = N + 1 'Счетчик размерности массива arr(N) = FName 'Заполнение ячейки массива FName = Dir 'Получение следующего имени файла Loop N = 0 'Цикл перебора файлов d = InputBox("Что ищем?") If IsNull(d) Then Exit Sub y = 1 For N = 1 To FQuant SumFlag = 0 p = PName & "\" 'Директория файлов f = arr(N) 'получаем имя файла s = Left(arr(N), Len(arr(N)) - 5) 'получаем имя листа 'On Error Resume Next Set WB = Workbooks.Open(p & f) 'Set WB = GetObject(p & f) 'Workbooks(f).Activate For Each Sht In WB.Sheets 'цикл по всем листам в файле Sht.PageSetup.LeftHeader = "" Sht.PageSetup.CenterHeader = "" Sht.PageSetup.RightHeader = "" Sht.PageSetup.LeftFooter = "" Sht.PageSetup.CenterFooter = "" Sht.PageSetup.RightFooter = "" Sht.PageSetup.LeftMargin = Application.InchesToPoints(0.393700787401575) Sht.PageSetup.RightMargin = Application.InchesToPoints(0.393700787401575) Sht.PageSetup.TopMargin = Application.InchesToPoints(0.393700787401575) Sht.PageSetup.BottomMargin = Application.InchesToPoints(0.393700787401575) Sht.PageSetup.HeaderMargin = Application.InchesToPoints(0) Sht.PageSetup.FooterMargin = Application.InchesToPoints(0) Sht.PageSetup.PrintHeadings = False Sht.PageSetup.PrintGridlines = False Sht.PageSetup.PrintComments = xlPrintNoComments Sht.PageSetup.PrintQuality = 600 Sht.PageSetup.CenterHorizontally = False Sht.PageSetup.CenterVertically = False Sht.PageSetup.Orientation = xlPortrait Sht.PageSetup.Draft = False Sht.PageSetup.PaperSize = xlPaperA4 Sht.PageSetup.FirstPageNumber = xlAutomatic Sht.PageSetup.Order = xlOverThenDown Sht.PageSetup.BlackAndWhite = False Sht.PageSetup.Zoom = False Sht.PageSetup.FitToPagesWide = 1 Sht.PageSetup.FitToPagesTall = False Sht.PageSetup.PrintErrors = xlPrintErrorsDisplayed Sht.PageSetup.OddAndEvenPagesHeaderFooter = False Sht.PageSetup.DifferentFirstPageHeaderFooter = False Sht.PageSetup.ScaleWithDocHeaderFooter = True Sht.PageSetup.AlignMarginsHeaderFooter = False Sht.PageSetup.EvenPage.LeftHeader.Text = "" Sht.PageSetup.EvenPage.CenterHeader.Text = "" Sht.PageSetup.EvenPage.RightHeader.Text = "" Sht.PageSetup.EvenPage.LeftFooter.Text = "" Sht.PageSetup.EvenPage.CenterFooter.Text = "" Sht.PageSetup.EvenPage.RightFooter.Text = "" Sht.PageSetup.FirstPage.LeftHeader.Text = "" Sht.PageSetup.FirstPage.CenterHeader.Text = "" Sht.PageSetup.FirstPage.RightHeader.Text = "" Sht.PageSetup.FirstPage.LeftFooter.Text = "" Sht.PageSetup.FirstPage.CenterFooter.Text = "" Sht.PageSetup.FirstPage.RightFooter.Text = "" Next Sht If Rng Is Nothing Then 'если не нашли GoTo Metka End If Metka: WB.Close Next N If Rng Is Nothing Then 'если не нашли MsgBox "Не найдено ни на одном листе ни в одной книге!", vbExclamation, "Конец" End If End If End With End Sub |
Работает он так: я запускаю код, в открывшемся окне выбираю папку, в следующем окне пишу "xls"(без кавычек, конечно), и код задаёт параметры печати - книжную ориентацию и умещение на одной странице - во всех найденных xls-файлах. Вот только делает он это очень медленно. Скажите, пожалуйста, можно ли его как-то ускорить?