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