Option Explicit

Private Function GetValue(path As String, file As String, sheet As String, ref As String) As Variant
    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
    
    ' Отключаем обновление экрана и автосохранение
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    'Вызываем диалоговое окно для определения папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Укажите папку, в которой находятся файлы"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "Отменено" 'Прекращение работы
            Exit Sub
        Else
            PName = .SelectedItems(1) 'Получение пути
        End If
    End With
    
    'Считаем количество файлов в папке для создания массива названий файлов
    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) 'получаем имя листа
        Set WB = Workbooks.Open(p & f)
        For Each Sht In WB.Sheets 'цикл по всем листам в файле
            ' Оптимизация настроек страницы
            With Sht.PageSetup
                .LeftHeader = ""
                .CenterHeader = ""
                .RightHeader = ""
                .LeftFooter = ""
                .CenterFooter = ""
                .RightFooter = ""
                .LeftMargin = Application.InchesToPoints(0.393700787401575)
                .RightMargin = Application.InchesToPoints(0.393700787401575)
                .TopMargin = Application.InchesToPoints(0.393700787401575)
                .BottomMargin = Application.InchesToPoints(0.393700787401575)
                .HeaderMargin = Application.InchesToPoints(0)
                .FooterMargin = Application.InchesToPoints(0)
                .PrintHeadings = False
                .PrintGridlines = False
                .PrintComments = xlPrintNoComments
                .PrintQuality = 600
                .CenterHorizontally = False
                .CenterVertically = False
                .Orientation = xlPortrait
                .Draft = False
                .PaperSize = xlPaperA4
                .FirstPageNumber = xlAutomatic
                .Order = xlOverThenDown
                .BlackAndWhite = False
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = False
                .PrintErrors = xlPrintErrorsDisplayed
                .OddAndEvenPagesHeaderFooter = False
                .DifferentFirstPageHeaderFooter = False
                .ScaleWithDocHeaderFooter = True
                .AlignMarginsHeaderFooter = False
                .EvenPage.LeftHeader.Text = ""
                .EvenPage.CenterHeader.Text = ""
                .EvenPage.RightHeader.Text = ""
                .EvenPage.LeftFooter.Text = ""
                .EvenPage.CenterFooter.Text = ""
                .EvenPage.RightFooter.Text = ""
                .FirstPage.LeftHeader.Text = ""
                .EvenPage.CenterHeader.Text = ""
                .FirstPage.RightHeader.Text = ""
                .FirstPage.LeftFooter.Text = ""
                .FirstPage.CenterFooter.Text = ""
            End With
        Next Sht
        WB.Close SaveChanges:=False
    Next N
    
    ' Включаем обновление экрана и автосохранение обратно
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Option Explicit
#If VBA7 Then
  Private Declare PtrSafe Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
#Else
  Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As String,ByVal lpReturnedString As String, ByVal nSize As Long) As Long
#End If

Sub ZVI_FastPageSettings()
' ZVI:2024-04-28 https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=164667
' Ускорить код, задающий параметры печати

  Const ISDEBUG = 0   ' 0/1 for Ready/Debug

  Static sFolder As String
  Dim sFile As String, sPrnName As String, sXpsName As String, sBuf As String, sDevices() As String
  Dim vFileName As Variant, ActSheet As Variant
  Dim Ws As Worksheet
  Dim colFiles As Collection
  Dim i As Long, j As Long, t As Long

  ' Choose Folder
  If sFolder = vbNullString Then sFolder = ThisWorkbook.Path & "\"
  With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = sFolder
    .Title = "Выберите папку с XLS* для установки парамеров страниц"
    .Show
    If .SelectedItems.Count = 0 Then
      MsgBox "Обработка файлов отменена", vbExclamation, "Завершение"
      Exit Sub
    Else
      sFolder = .SelectedItems(1) & "\"
    End If
  End With

  ' Collect file names
  Set colFiles = New Collection
  sFile = Dir(sFolder & "*.XLS*", vbNormal)
  While sFile <> vbNullString
    colFiles.Add sFolder & sFile
    sFile = Dir()
  Wend
  If colFiles.Count = 0 Then
    MsgBox "Нет XLS* файлов в папке:" & vbLf & sFolder, vbExclamation, "Завершение"
    Exit Sub
  End If

  ' Save current printer name
  sPrnName = Application.ActivePrinter

  ' Temporary set up XPS printer
  If Not sPrnName Like "*XPS*" Then
    sBuf = String(2 ^ 14, Chr(0))
    i = GetProfileString("Devices", vbNullString, vbNullString, sBuf, Len(sBuf))
    sBuf = Left(sBuf, i)
    For Each vFileName In Split(sBuf, Chr(0))
      If vFileName Like "*XPS*" Then
        sXpsName = vFileName & " (Ne" & Right("00" & j, 2) & ":)"
        Application.ActivePrinter = sXpsName
        Exit For
      End If
      j = j + 1
    Next
  End If

  ' Disable screen blinking & events
  If Not ISDEBUG Then
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    On Error GoTo exit_
  End If

  ' Disable PrintCommunication
  Application.PrintCommunication = False

  ' Process XLS* files in the choosen folder
  j = 0
  i = colFiles.Count
  t = Timer
  For Each vFileName In colFiles
    With Workbooks.Open(vFileName, UpdateLinks:=False)
      j = j + 1
      Set ActSheet = .ActiveSheet
      Application.StatusBar = "Файл " & j & " из " & i & " : " & .Name
      Application.PrintCommunication = False
      For Each Ws In .Worksheets
        If Ws.Visible Then
          Ws.DisplayPageBreaks = False
          Ws.Activate
          ActiveWindow.View = xlNormalView
          With Ws.PageSetup
            .PaperSize = xlPaperA4
            .Orientation = xlPortrait
            .FitToPagesWide = 1
            .FitToPagesTall = False
          End With
        End If
      Next
      Application.PrintCommunication = True
      ActSheet.Activate
      .Close SaveChanges:=True
    End With
  Next
  t = Timer - t
  Application.StatusBar = False

  ' Restore previous active printer
  Application.ActivePrinter = sPrnName

exit_:

  ' Set NormalView in ActiveSheet
  ActiveWindow.View = xlNormalView
  ActiveSheet.DisplayPageBreaks = False
  
  ' Restore disabled settings
  Application.PrintCommunication = True
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  
  ' Show statistics/error
  If Err Then
    MsgBox Err.Description, vbCritical, "Ошибка: " & Err.Number
  Else
    MsgBox "Успешно обработано файлов: " & colFiles.Count _
         & " за " & t & " сек" & vbLf _
         & "В папке:" & vbLf & sFolder, vbInformation, "Завершение"
  End If

End Sub