' Сортируем таблицу по столбцу 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

ПРОСМОТР(2;1/($A7=$A$3:$A6);P$3:P6)

=ЕСЛИ(И(G3="Основной";C3="Покупка");H2-F3;(ЕСЛИ(И(G3="Основной";C3="Продажа");
H2-F3;(ЕСЛИ(И(G3="Основной";C3="Зачисление");H2+F3;(ЕСЛИ(И(G3="Основной";C3="Списание");H2-F3;)))))))

 =ЕСЛИ(ЕПУСТО(ЕСЛИОШИБКА(ИНДЕКС('План закупки'!$A$24:$AT$27;ПОИСКПОЗ(ЗАКУПКИ!$B5;'План закупки'!$F$24:$F$27;0);15);""));"";ЕСЛИОШИБКА(ИНДЕКС('План закупки'!$A$24:$AT$27;ПОИСКПОЗ(ЗАКУПКИ!$B5;'План закупки'!$F$24:$F$27;0);15);""))

Function GetFilePath(Optional ByVal Title As String = "Выберите файл Контракта", _
                     Optional ByVal InitialPath As String = "C:\", _
                     Optional ByVal FilterDescription As String = "Документы Adobe", _
                     Optional ByVal FilterExtention As String = "*.pdf*") As String
    ' функция выводит диалоговое окно выбора файла с заголовком Title,
    ' начиная обзор диска с папки InitialPath
    ' возвращает полный путь к выбранному файлу, или пустую строку в случае отказа от выбора
    ' для фильтра можно указать описание и расширение выбираемых файлов
    On Error Resume Next
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtention
        If .Show <> -1 Then Exit Function
        GetFilePath = .SelectedItems(1): PS = Application.PathSeparator
    End With
End Function
 
Sub Гиперссылка_на_файл()
    ИмяФайла = GetFilePath ' запрашиваем имя файла
    If ИмяФайла = "" Then Exit Sub    ' выход, если пользователь отказался от выбора файла
 Selection.Formula = "=ГИПЕРССЫЛКА(" & ИмяФайла & ";" & Application.InputBox("Введите номер Контракта") & ")"
End Sub

Sub ЗаменаИспорченныхГиперссылок()
    On Error Resume Next
    Dim hl As Hyperlink, oldString As String, newString As String, sh As Worksheet
    ' часть гиперссылки, подлежащая замене
    oldString = "\\192.168.0.200\Users\User\AppData\Roaming\Microsoft"
    ' на что заменяем
    newString = "\\192.168.0.200\обмен"
    For Each sh In ActiveWorkbook.Worksheets    ' перебираем все листы в активной книге
        For Each hl In sh.Hyperlinks    ' перебираем все гиперссылки на листе
            If hl.Address Like oldString & "*" Then
                hl.Address = Replace(hl.Address, oldString, newString)
            End If
        Next
    Next sh
End Sub