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

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

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 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

Sub Visota(ByRef ra As Range)        Dim CurrCell As Range, cell As Range, ma As Range: Dim col As Range, ro As Range
        Application.ScreenUpdating = False
    For Each ro In ra.Rows
                maxRH = 0
        For Each cell In ro.Cells
            If cell.MergeCells And cell.Address = cell.MergeArea.Cells(1).Address Then
                Debug.Print cell.Address
                Set ma = cell.MergeArea: newCW = 0
                With ma
                    cw = .Columns(1).ColumnWidth: .UnMerge
                    For Each col In .EntireColumn: newCW = newCW + col.ColumnWidth: Next
                    .Columns(1).ColumnWidth = newCW: .EntireRow.AutoFit
                    rh = .EntireRow.RowHeight: If rh > maxRH Then maxRH = rh
                    .Merge: .Columns(1).ColumnWidth = cw
                End With
            End If
        Next cell
        If maxRH > 0 Then ro.EntireRow.RowHeight = maxRH
    Next ro
    Application.ScreenUpdating = True
End Sub
Sub RunVisota()
          Visota Worksheets("Заключ.").Range("c10:c37", "d41:i50")
          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
Sub Otobrazyt()
    Columns.Hidden = False   'отменяем все скрытия строк и столбцов
    Rows.Hidden = False
End Sub
Sub otobrazyt_2()
    Range("c10", "f68").WrapText = False
    Columns.Hidden = False   'отменяем все скрытия строк и столбцов
    Rows.Hidden = False
End Sub
Sub Skryt()
Range("c10", "f68").WrapText = True
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

Sub Visota(ByRef ra As Range)
        Dim CurrCell As Range, cell As Range, ma As Range: Dim col As Range, ro As Range
    For Each ro In ra.Rows
        Application.ScreenUpdating = False
        maxRH = 0
        For Each cell In ro.Cells
            If cell.MergeCells And cell.Address = cell.MergeArea.Cells(1).Address Then
                Debug.Print cell.Address
                Set ma = cell.MergeArea: newCW = 0
                With ma
                    cw = .Columns(1).ColumnWidth: .UnMerge
                    For Each col In .EntireColumn: newCW = newCW + col.ColumnWidth: Next
                    .Columns(1).ColumnWidth = newCW: .EntireRow.AutoFit
                    rh = .EntireRow.RowHeight: If rh > maxRH Then maxRH = rh
                    .Merge: .Columns(1).ColumnWidth = cw
                End With
            End If
        Next cell
        If maxRH > 0 Then ro.EntireRow.RowHeight = maxRH
    Next ro
    Application.ScreenUpdating = True
End Sub
Sub RunVisota()
          Visota ActiveSheet.UsedRange
End Sub

Option Explicit
  
Const FoundWhat = "0"
  
Sub HideRows()
    FindInWb ActiveWorkbook
End Sub
  
Sub ShowRows()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        sh.UsedRange.EntireRow.Hidden = False
    Next
End Sub
  
Sub FindInWb(wb As Workbook)
    Dim sh As Worksheet
    Dim arrSheets As Variant
    Dim v As Variant
     
    'указываем названия листов в кавычках через запятую
    arrSheets = Array("Лист1", "Лист2", "Лист3", "Лист4")
     
    For Each v In arrSheets
        Set sh = wb.Worksheets(v)
        FindInSheet sh
    Next
End Sub
  
Sub FindInSheet(sh As Worksheet)
    With sh.UsedRange
        Dim FoundCell As Range
        Dim LastCell As Range
        Dim FirstAddr As String
        Set LastCell = .Cells(.Rows.Count, .Columns.Count)
        Set FoundCell = .Find(what:=FoundWhat, after:=LastCell)
          
        If Not FoundCell Is Nothing Then
            FirstAddr = FoundCell.Address
        End If
        Do Until FoundCell Is Nothing
            FoundCellJob FoundCell
            Set FoundCell = .FindNext(after:=FoundCell)
            If FoundCell.Address = FirstAddr Then
                Exit Do
            End If
        Loop
    End With
End Sub
  
Sub FoundCellJob(cl As Range)
    cl.EntireRow.Hidden = True
End Sub

Private Sub Worksheet_Calculate()
    If [A1] = 0 Then
        Columns(5).EntireColumn.Hidden = True
    Else
        Columns(5).EntireColumn.Hidden = False
    End If
End Sub