Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
Макрос, который из нескольких файлов печатает нужные листы(вкладки) согласно списка в столбце
 
Есть макрос, который из нескольких файлов печатает нужные листы(вкладки) согласно списка в столбце (работает по принципу: выбирается нужная папка для печати, затем открывается файл - проверяется наличие вкладки - на печать, закрывается и следующий...).

Все бы хорошо, но один косяк: отправляет по одному листу, и если много чего печатать, то получается задание на печать из длинного списка по 1-5 страницам в каждом. Принтер очень долго обрабатывает каждое задание. Хотелось бы, чтобы всю эту кучу задач объединить воедино и на принтер отправлялось одним файлом с множеством страниц (или по группам както объединить, но уменьшить число задач в итоге. Страницы в экселе подогнаны под А4. Возможно оптимизируете программу - изначально он открывает файл - проверяет 1 ячеку из таблицы листов, потом открывает и проверяет 2 ячейку и так каждый файл (изначально задача, чтобы печатал именно все листы одного названия из всех файлов, потом все листы другого из всех файлов...
Код
Sub Печать()
'Печатает поочередно каждый Лист из заданного списка последовательно из всех файлов выбранной папки

Application.ScreenUpdating = True

Dim MyWorkbook As Workbook, MyWorkbook2 As Workbook
Dim MyRange As Range
Dim LastRow As Long, i As Long, w As Long
Dim MyFileName As String, MyFileFullName As String
Dim ListToPrint

'MyWorkbook = ActiveWorkbook
LastRow = Range("B2").CurrentRegion.Rows.Count
Set MyRange = ThisWorkbook.Worksheets(1).Range("B2:B" & 2 + LastRow - 1)

ListToPrint = MyRange.Value

'Пользователь выбирает папку с файлами для печати
If MsgBox("Выберите папку с файлами для печати:", vbOKCancel) = vbCancel Then
  MsgBox "Папка не выбрана"
  Exit Sub
End If

MyPapka = GetFolder()
'оффаемся, если папка не выбрана
If MyPapka = "" Then
  MsgBox "Папка не выбрана"
  Exit Sub
End If

Application.ScreenUpdating = False
'Печать последовательно каждой страницы из всех файлов типа *123*
On Error Resume Next

For i = LBound(ListToPrint, 1) To UBound(ListToPrint, 1)
  MyFileName = Dir(MyPapka & "*123*")
  Do While Len(MyFileName) > 0
          MyFileFullName = MyPapka & MyFileName
          Set MyWorkbook2 = Workbooks.Open(MyFileFullName)
          'Печатаем i-ый Лист из всех файлов, если есть данные
          For w = 1 To MyWorkbook2.Worksheets.Count
              If MyWorkbook2.Worksheets(w).Name = ListToPrint(i, 1) Then
                  With MyWorkbook2.Worksheets(ListToPrint(i, 1))
                      .Activate
                      If Not IsEmpty(.Range("A4").Value) And Not IsEmpty(.Range("B4").Value) And Not IsEmpty(.Range("C4").Value) Then
                          MyWorkbook2.Worksheets(ListToPrint(i, 1)).PrintOut
                          'Debug.Print MyFileName, ListToPrint(i, 1), MyWorkbook2.Worksheets(ListToPrint(i, 1)).Range("A4").Value,
                          'MyWorkbook2.Worksheets(ListToPrint(i, 1)).Range("B4").Value , MyWorkbook2.Worksheets(ListToPrint(i, 1)).Range("C4").Value
                      End If
                      Exit For
                  End With
              End If
          Next w
          MyWorkbook2.Close (False)
      'выбираем новый файл:
      MyFileName = Dir()
  Loop
Next i

Application.ScreenUpdating = True
End Sub
Страницы: 1
Наверх