Sub Собрать_данные()
      Application.ScreenUpdating = False
    ' Макрос собирает данные на активном листе активной книги из всех листов "Форма" xls файлов заданной директории,
    Dim ImenaListovSbora: ImenaListovSbora = Array("Сводный_лист")
    Const FirstRow_Cel& = 4          ' Номер строки начала построения
    Const FirstRow& = 4              ' Номер строки начала сбора данных (ниже шапки)
    Dim i&, LastRow&, LastRow_Cel&
    Dim ShCel As Worksheet, Sh As Worksheet, wb_Tek As Workbook
    Dim MyPath$, MyFileName$, MyFullName$
    Set ShCel = ActiveSheet
    LastRow_Cel = FirstRow_Cel
    With ShCel
        i = .UsedRange.Rows.Count + .UsedRange.Row - 1
        If i < FirstRow_Cel Then i = FirstRow_Cel
        .Rows(FirstRow_Cel & ":" & i).ClearContents
    End With
    MyPath = Trim$(ShCel.[C1])
    If Right$(MyPath, 1) <> "" Then MyPath = MyPath & ""
    MyFileName = Dir(MyPath & "*.xls*")
    Do Until MyFileName = ""
        MyFullName = MyPath & MyFileName
        Set wb_Tek = Workbooks.Open(Filename:=MyFullName, UpdateLinks:=0, ReadOnly:=True)
        For Each Sh In wb_Tek.Worksheets
            For i = 0 To UBound(ImenaListovSbora)
                If Sh.Name = ImenaListovSbora(i) Then
                    With Sh
                        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                        .Range(.Cells(FirstRow, 1), .Cells(LastRow, 8)).Copy
                        ShCel.Cells(LastRow_Cel, 1).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        LastRow_Cel = LastRow_Cel + LastRow - FirstRow + 1
                    End With
                End If
            Next
        Next Sh
        wb_Tek.Close SaveChanges:=False
        MyFileName = Dir
    Loop
    With ShCel
        .Range(.Cells(LastRow_Cel - 1, 1), .Cells(LastRow_Cel - 1, 8)).Copy
        .Cells(LastRow_Cel, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
        .Cells(LastRow_Cel, 2).Select
    End With
End Sub

Sub Signature2()            ' Макрос для проставления колонтитула (меняет колонтитул на всех листа)
Dim xSh As Worksheet
    For Each xSh In Worksheets
        CodSignature2 xSh
    Next
End Sub
 Sub CodSignature2(ws As Worksheet)
  With ws.PageSetup
    .LeftFooter = "               Шифр: " & ['Ввод общих данных'!H19] & " № " & ['Ввод общих данных'!M7] & " " & ['Ввод общих данных'!H9] & " - " & ['Ввод общих данных'!H15]
    .CenterFooter = ""
    .RightFooter = "Лист  &P" & "     Листов &N  "
  End With
End Sub

Function GetFileName(Optional ByVal Title As String)
    If Not IsMissing(InitialPath) Then
        On Error Resume Next: ChDrive Left(InitialPath, 1)
        ChDir InitialPath    ' выбираем стартовую папку
    End If
    res = Application.GetOpenFilename(MyFilter, , Title, "Открыть")  ' вывод диалогового окна
    GetFileName = IIf(VarType(res) = vbBoolean, "", res)    ' пустая строка при отказе от выбора
End Function
Sub AttachFile_test()    ' пример использования
    Application.ScreenUpdating = False
    Filename$ = GetFileName
    If Filename$ = "" Then Exit Sub
'    MsgBox "Выбран файл: " & Filename$
    On Error Resume Next
        Set sh = ThisWorkbook.Sheets(Application.Caller)
        If Err <> 0 Then MsgBox "Нет такого листа": Exit Sub
    On Error GoTo 0
    Set openWb = Workbooks.Open(Filename$)
    sh.UsedRange.Clear
    openWb.ActiveSheet.UsedRange.Copy sh.[a1]
    openWb.Close False
    Application.ScreenUpdating = True
End Sub

If Sheet1.Range("A1").Value = 0 Then

'здесь укажите, какие листы нужно сохранить в PDF    
Worksheets(Array("Лист1", "Лист3")).Select

Sub Signature()Dim xSh As Worksheet
    For Each ws In ActiveWindow.SelectedSheets
    CodSignature xSh
    Next
End Sub
 Sub CodSignature(ws As Worksheet)
    With ws.PageSetup
    .LeftFooter = "               Øèôð: " & ['Ââîä îáùèõ äàííûõ'!H19] & " ¹ " & ['Ââîä îáùèõ äàííûõ'!M7] & " " & ['Ââîä îáùèõ äàííûõ'!H9] & " - " & ['Ââîä îáùèõ äàííûõ'!H15]
    .CenterFooter = ""
    .RightFooter = "Ëèñò  &P" & "     Ëèñòîâ &N  "
  End With
End Sub

 Sub CodSignature(ws As Worksheet)

with ws                         .LeftFooter = "               Шифр: " & ['Ввод общих данных'!H19] 
    .CenterFooter = ""
    .RightFooter = "Лист  &P" & "     Листов &N  "

Sub Signature()                             'Для колонтитула
   With ActiveSheet.PageSetup
       .LeftFooter = "               Шифр: " & ['Ввод общих данных'!H19] 
       .CenterFooter = ""
       .RightFooter = "Лист  &P" & "     Листов &N  "
   End With
End Sub

Sub Signature()                           
Dim xSh As Worksheet
    Application.ScreenUpdating = False
    For Each xSh In Worksheets
        xSh.Select
        Call CodSignature
    Next
    Application.ScreenUpdating = True
End Sub
Sub CodSignature()                             
       .LeftFooter = "               Шифр: " & ['Ввод общих данных'!H19] 
       .CenterFooter = ""
       .RightFooter = "Лист  &P" & "     Листов &N  "
   End With
End Sub

Sub Sborka()
    RunVisota
    Skryt
    Skryt2
End Sub

Sub Skryt()
    With Worksheets("Поясн. запис.")
    .Range("c10", "f68").WrapText = True
  End With
        Dim cell As Range
    Application.ScreenUpdating = False                              'отключаем обновление экрана для ускорения
    For Each cell In ActiveSheet.UsedRange.Rows(1).Cells            'проходим по всем ячейкам первой строки
        If cell.Value = "x" Then cell.EntireColumn.Hidden = True    'если в ячейке x - скрываем столбец
    Next
    For Each cell In ActiveSheet.UsedRange.Columns(1).Cells         'проходим по всем ячейкам первого столбца
        If cell.Value = "x" Then cell.EntireRow.Hidden = True       'если в ячейке x - скрываем строку
    Next
      Application.ScreenUpdating = True
    End Sub