Sub Отчёт_сроки()
    On Error Resume Next
    ' название подпапки, в которую по-умолчанию будет предложено сохранить файл
    Const REPORTS_FOLDER = "Отчёты\"
    ' создаём папку для файла, если её ещё нет
    'MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
    ' выбираем стартовую папку
    ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
r = Format(Now(), "dd.mm.yyyy")
    ' вывод диалогового окна для запроса имени сохраняемого файла
    Filename = Application.GetSaveAsFilename(r & " сроки.xlsx", "Отчёты Excel (*.xlsx),", , _
                                             "Введите имя файла для сохраняемого отчёта", "Сохранить")
    ' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
    If VarType(Filename) = vbBoolean Then Exit Sub

    ' копируем активный лист (при этом создаётся новая книга)
    Err.Clear: ActiveSheet.Copy: DoEvents
    If Err Then Exit Sub    ' произошла какая-то ошибка при попытке копирования листа

    ' убеждаемся, что активной книгой является копия листа
    If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
    
'убираем все формулы в таблице
     Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
 ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!сортируем таблицу по столбцу AT "Заголовок 45" автофильтром от старых к новым
     ActiveWorkbook.Worksheets("План закупки").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("План закупки").AutoFilter.Sort.SortFields.Add Key _
        :=Range("AT7:AT2000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("План закупки").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!Ставим в автофильтре столбца K (11-й слева по счету) "Филиал" отбор по содержанию фразы "ЦФО"
     ActiveSheet.Range("$A$7:$CV$2000").AutoFilter Field:=11, Criteria1:="*" & "ЦФО" & "*", Operator:=xlAnd
   
    
        ' сохраняем файл под заданным именем в формате Excel 2003
        'ActiveWorkbook.SaveAs Filename, xlWorkbookNormal
        
        ' сохраняем файл под заданным именем в формате XLSX
        Application.DisplayAlerts = False ' отключаем вывод предупреждения о потере точности
        ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook ' xlOpenXMLWorkbook = формат XLSX
        Application.DisplayAlerts = True ' обратно включаем вывод предупреждений

        ' закрываем сохранённый файл
        ' (удалите следующую строку, если закрывать созданный файл не требуется)
        ' ActiveWorkbook.Close False
    End If
End Sub

' Сортируем таблицу по столбцу AT от старых к новым
ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Add Key _
        :=Range("AT7:AT2000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
'Ставим в автофильтре стобца K (11-й слева по счету) отбор по содержанию фразы "ЦФО"
     ActiveSheet.Range("$A$7:$CV$2000").AutoFilter Field:=11, Criteria1:="*" & "ЦФО" & "*", Operator:=xlAnd

Option Explicit
 
Dim objFSO As Object, objFolder As Object, objFile As Object
 
Sub Get_All_File_from_SubFolders()
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders sFolder
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Sub

Private Sub GetSubFolders(sPath)
    Dim sPathSeparator As String, sObjName As String
    Dim wb As Workbook
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            'открываем книгу
            Set wb = Application.Workbooks.Open(sPath & objFile.Name)
            'действия с файлом: Снимем пароль
            wb.Sheets(1).Unprotect "123"
            'Запишем на первый лист книги в ячейку А1 текущую дату
            wb.Sheets(1).Range("A1").Value = Format(Now, "dd.mm.yyyy")
            'Снимем все возможные автофильтры
            On Error Resume Next: wb.Sheets(1).ShowAllData: On Error GoTo 0
            'Закрасим ячейки цветом
            Range("O5:AB1000").Interior.Color = RGB(255, 255, 204)
            'Ставим пароль по определенному условию
            wb.Sheets(1).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, AllowInsertingRows:=True, AllowFiltering:= _
        True, Password:="123"
            wb.Close True
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
End Sub

Private Sub GetSubFolders2(ByVal sPath As String, Optional ByVal lCounter As Long = 0)
    Dim sPathSeparator As String, sObjName As String
    Dim wb As Workbook
'    Dim lCounter As Long: lCounter = 0
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            'открываем книгу
            Set wb = Application.Workbooks.Open(sPath & objFile.Name)
            'действия с файлом
            With ThisWorkbook.Worksheets("НЕ ВХОДИТЬ!!!").Range("A1")
                .Offset(lCounter).Value = wb.Sheets(1).Range("A1").Value
                .Offset(lCounter, 1).Value = objFile.Name
                lCounter = lCounter + 1
            End With
            wb.Close True
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders2 objFolder.Path & Application.PathSeparator, lCounter
    Next
End Sub 'GetSubFolders2

Sub call_GetSubFolders2()
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    With ThisWorkbook.Worksheets("НЕ ВХОДИТЬ!!!")
        .Range("A1", .Cells.SpecialCells(xlCellTypeLastCell)).EntireColumn.Resize(, 2).ClearContents
    End With
    
    GetSubFolders2 sFolder
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Sub

Private Sub GetSubFolders2(sPath)
    Dim sPathSeparator As String, sObjName As String
    Dim wb As Workbook
    Dim lCounter As Long: lCounter = 0
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
             'открываем книгу
            Set wb = Application.Workbooks.Open(sPath & objFile.Name)
            'действия с файлом
            With ThisWorkbook.Worksheets("Лист1").Range("A1")
        .Offset(lCounter).Value = wb.Sheets(1).Range("A1").Value
        .Offset(lCounter, 1).Value = objFile.Name
        lCounter = lCounter + 1
    End With
            wb.Close True
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders2 objFolder.Path & Application.PathSeparator
    Next
End Sub

' Purpose   : http://www.excel-vba.ru/chto-umeet-excel/prosmotret-vse-fajly-v-papke/
'---------------------------------------------------------------------------------------
Option Explicit
 
Dim objFSO As Object, objFolder As Object, objFile As Object
 
Sub Get_All_File_from_SubFolders()
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders sFolder
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Sub
Private Sub GetSubFolders(sPath)
    Dim sPathSeparator As String, sObjName As String
    Dim wb As Workbook
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            'открываем книгу
            Set wb = Application.Workbooks.Open(sPath & objFile.Name)
            'действия с файлом
            'Запишем на первый лист книги в ячейку А1 - текущая дата
            wb.Sheets(1).Range("A1").Value = Format(Now, "dd.mm.yyyy")
            'Меняем цвет ячеек A4:D8
            Range("A4:D8").Interior.Color = RGB(100, 150, 250)
            'Ставим пароль на текущий лист каждого файла 123
            wb.Sheets(1).Protect "123"
            wb.Close True
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
End Sub