=СУММЕСЛИМН(R138:R927;$Q$26:$Q$927;$Q$138;$O$138:$O$927;4;$M$138:$M$927;$M$138)

Sub ExportFilteredTable2()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim filteredTbl As Range
    Dim newWorkbook As Workbook

    Set ws = ThisWorkbook.Worksheets("Свод поручений") 'Установка листа по имени
    Set tbl = ws.ListObjects("Table1") 'Установка таблицы
    Set filteredTbl = tbl.Range.SpecialCells(xlCellTypeVisible) 'Вся таблица с заголовками и отфильтрованными строками

    'Присвоение имени новой книге
    Dim newBookName As String
             
    Set newWorkbook = Workbooks.Add
    

    'Копирование отфильтрованных значений с сохранением форматирования в новую книгу
   filteredTbl.Copy
 
   newWorkbook.Worksheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
   newWorkbook.Worksheets(1).Range("A1").PasteSpecial xlPasteAll

   
     newWorkbook.Worksheets(1).Cells.EntireColumn.AutoFit
    
    newBookName = "Поручения от " & newWorkbook.Worksheets(1).Range("C2").Value  'ws.Range("C2").Value
   newWorkbook.SaveAs fileName:=newBookName
   
    'Открытие новой книги
    newWorkbook.Activate

    'Очистка буфера обмена
    Application.CutCopyMode = False
End Sub

Sub ExportFilteredData()
    'Declare variables
    Dim ws As Worksheet
    Dim rng As Range
    Dim newFile As Workbook
    Dim filterRange As String
    
    'Set worksheet and filtered range
    Set ws = ThisWorkbook.ActiveSheet
    filterRange = ws.Range("A3").CurrentRegion.Address
    
    'Filter the data
    ws.Range(filterRange).AutoFilter Field:=1, Criteria1:="<>0"
    
    'Set the range to be copied
    Set rng = ws.Range(filterRange).SpecialCells(xlCellTypeVisible)
    
    'Create a new workbook
    Set newFile = Workbooks.Add
    
    'Copy the filtered data to the new workbook
    rng.Copy newFile.Sheets(1).Range("A1")
    
    'Save the new workbook with the specified name
    newFile.SaveAs ThisWorkbook.Path & "\Поручения от " & Format(ws.Range("C3").Value, "dd.mm.YYYY") & ".xlsx"
End Sub

Set ol = New Outlook.Application
    Set ns = ol.GetNamespace("MAPI")
   Set fol = ns.Folders(1).Folders("123")

Sub SaveOutlookAttachments()

    'This early-binding version requires a reference to the Outlook and Scripting Runtime object libraries
    
    Dim ol As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim fol As Outlook.Folder
    Dim i As Object
    Dim mi As Outlook.MailItem
    Dim at As Outlook.Attachment
    Dim fso As Scripting.FileSystemObject
    Dim dir As Scripting.Folder
    Dim dirName As String
    
    Set fso = New Scripting.FileSystemObject
    
    Set ol = New Outlook.Application
    Set ns = ol.GetNamespace("MAPI")
   Set fol = ns.Folders(1).Folders("123")
    
  For Each i In fol.Items
    
        If i.Class = olMail Then
        
         Set mi = i
            
          If mi.Attachments.Count > 0 Then
               'Debug.Print mi.SenderName, mi.ReceivedTime, mi.Attachments.Count
                
              dirName = _
            "D:\Outlook Files\" '& _
        '            Format(mi.ReceivedTime, "yyyy-mm-dd hh-nn-ss ") & _
         '           Left(Replace(mi.Subject, ":", ""), 10)
                
                If fso.FolderExists(dirName) Then
                    Set dir = fso.GetFolder(dirName)
                Else
                   Set dir = fso.CreateFolder(dirName)
                End If
                
                For Each at In mi.Attachments
                
                    Debug.Print vbTab, at.DisplayName, at.Size
                   at.SaveAsFile dir.Path & "\" & at.Filename
                    
                Next at
                
            End If
            
        End If
    
    Next i
    
End Sub