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

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