Option Explicit
'v4
Sub Суммировать_выделенные_ячейки()
    CloseEmptyWb
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    Set rr = Intersect(rr, rr.Cells(1, 1).EntireColumn)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    
    SumRange rr
End Sub

Private Sub SumRange(rr As Range)
    Dim rOut As Range
'    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    Application.Calculation = xlCalculationAutomatic
    
    Dim rArea As Range
    For Each rArea In rr.Areas
        SumArea rArea, rOut
    Next
    
    rOut.Parent.Parent.Saved = True
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Private Sub SumArea(rArea As Range, rOut As Range)
'    Set rOut = rOut.Resize(rArea.Rows.Count)
    Set rOut = rArea
    
    If Intersect(rArea, rOut) Is Nothing Then
        Dim xa As Variant
        For Each xa In Array(1, 5, 9, 11)
            rArea.Columns(xa).Copy rOut.Cells(1, xa).Resize(rArea.Rows.Count)
        Next
    End If
        
    rOut.Columns(21).Clear
    rOut.Columns(21).FormulaR1C1 = "=RC[" & 5 - 21 & "]"
'    rOut.Columns(27).Clear
    
    Dim yo As Long, yOpt As Long, yb As Long, dd As Double, duMin As Double
    For yo = 1 To rOut.Rows.Count
        If rOut.Cells(yo, 21).Value > 0 Then
            yOpt = 0
            For yb = 1 To rOut.Rows.Count
                If yo <> yb Then
                    If rOut.Cells(yo, 1).Value = rOut.Cells(yb, 1).Value Then
                        If rOut.Cells(yb, 21).Value > 0 Then
                            dd = rOut.Cells(yo, 21).Value + rOut.Cells(yb, 21).Value
                            dd = rOut.Cells(yb, 11).Value - dd
                            If dd >= 0 Then
                                If dd < duMin Or yOpt = 0 Then
                                    yOpt = yb
                                    duMin = dd
                                End If
                            End If
                        End If
                    End If
                End If
            Next
            If yOpt <> 0 Then
                rOut.Cells(yOpt, 21).Formula = rOut.Cells(yOpt, 21).Formula & "+" & rOut.Cells(yo, 5).Address(0, 0, xlA1)
                rOut.Cells(yo, 21).Formula = rOut.Cells(yo, 21).Formula & "-" & rOut.Cells(yo, 5).Address(0, 0, xlA1)
            End If
'                        If rOut.Cells(yb, 26 + 1).Value >= 0 Then
'                            If rOut.Cells(yo, 26).Value <= rOut.Cells(yb, 11).Value - rOut.Cells(yb, 26).Value Then
'                                If rOut.Cells(yo, 26).Value < rOut.Cells(yb, 26).Value Then
'                                    If rOut.Cells(yb, 26 + 1).Formula = "" Then
'                                        rOut.Cells(yb, 26 + 1).Formula = "=" & rOut.Cells(yo, 5).Address(0, 0, xlA1)
'                                    Else
'                                        rOut.Cells(yb, 26 + 1).Formula = rOut.Cells(yb, 26 + 1).Formula & "+" & rOut.Cells(yo, 5).Address(0, 0, xlA1)
'                                    End If
'                                    rOut.Cells(yo, 26 + 1).FormulaR1C1 = "=-RC[" & 5 - 26 - 1 & "]"
'                                Else
'                                    If rOut.Cells(yo, 26 + 1).Formula = "" Then
'                                        rOut.Cells(yo, 26 + 1).Formula = "=" & rOut.Cells(yb, 5).Address(0, 0, xlA1)
'                                    Else
'                                        rOut.Cells(yo, 26 + 1).Formula = rOut.Cells(yo, 26 + 1).Formula & "+" & rOut.Cells(yb, 5).Address(0, 0, xlA1)
'                                    End If
'                                    rOut.Cells(yb, 26 + 1).FormulaR1C1 = "=-RC[" & 5 - 26 - 1 & "]"
'                                End If
'                                Exit For
'                            End If
'                        End If
'                    End If
'                End If
'            End If
            
        End If
    Next
    
    Set rOut = rOut.Cells(rOut.Rows.Count + 1, 1)
End Sub

Option Explicit
'v3
Sub Суммировать_выделенные_ячейки()
    CloseEmptyWb
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    Set rr = Intersect(rr, rr.Cells(1, 1).EntireColumn)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    
    SumRange rr
End Sub

Private Sub SumRange(rr As Range)
    Dim rOut As Range
'    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    Application.Calculation = xlCalculationAutomatic
    
    Dim rArea As Range
    For Each rArea In rr.Areas
        SumArea rArea, rOut
    Next
    
    rOut.Parent.Parent.Saved = True
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Private Sub SumArea(rArea As Range, rOut As Range)
'    Set rOut = rOut.Resize(rArea.Rows.Count)
    Set rOut = rArea
    
    If Intersect(rArea, rOut) Is Nothing Then
        Dim xa As Variant
        For Each xa In Array(1, 5, 9, 11)
            rArea.Columns(xa).Copy rOut.Cells(1, xa).Resize(rArea.Rows.Count)
        Next
    End If
        
'    rOut.Columns(26).Clear
    rOut.Columns(21).FormulaR1C1 = "=RC[" & 5 - 21 & "]"
'    rOut.Columns(27).Clear
    
    Dim yo As Long, yOpt As Long, yb As Long, dd As Double, duMin As Double
    For yo = 1 To rOut.Rows.Count
        If rOut.Cells(yo, 21).Value > 0 Then
            yOpt = 0
            For yb = 1 To rOut.Rows.Count
                If yo <> yb Then
                    If rOut.Cells(yo, 1).Value = rOut.Cells(yb, 1).Value Then
                        If rOut.Cells(yb, 21).Value > 0 Then
                            dd = rOut.Cells(yo, 21).Value + rOut.Cells(yb, 21).Value
                            dd = rOut.Cells(yb, 11).Value - dd
                            If dd >= 0 Then
                                If dd < duMin Or yOpt = 0 Then
                                    yOpt = yb
                                    duMin = dd
                                End If
                            End If
                        End If
                    End If
                End If
            Next
            If yOpt <> 0 Then
                rOut.Cells(yOpt, 21).Formula = rOut.Cells(yOpt, 21).Formula & "+" & rOut.Cells(yo, 5).Address(0, 0, xlA1)
                rOut.Cells(yo, 21).Formula = rOut.Cells(yo, 21).Formula & "-" & rOut.Cells(yo, 5).Address(0, 0, xlA1)
            End If
        End If
    Next
    
    Set rOut = rOut.Cells(rOut.Rows.Count + 1, 1)
End Sub

Option Explicit
'v2
Sub Суммировать_выделенные_ячейки()
    CloseEmptyWb
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    Set rr = Intersect(rr, rr.Cells(1, 1).EntireColumn)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    
    SumRange rr
End Sub

Private Sub SumRange(rr As Range)
    Dim rOut As Range
'    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    Application.Calculation = xlCalculationAutomatic
    
    Dim rArea As Range
    For Each rArea In rr.Areas
        SumArea rArea, rOut
    Next
    
    rOut.Parent.Parent.Saved = True
End Sub

Private Sub SumArea(rArea As Range, rOut As Range)
'    Set rOut = rOut.Resize(rArea.Rows.Count)
    Set rOut = rArea
    
    Dim xa As Variant
    For Each xa In Array(1, 5, 9, 11)
        rArea.Columns(xa).Copy rOut.Cells(1, xa).Resize(rArea.Rows.Count)
    Next
    
    rOut.Columns(26).Clear
    rOut.Columns(26).FormulaR1C1 = "=RC[" & 5 - 26 & "]+RC[1]"
    rOut.Columns(27).Clear
    
    Dim yo As Long, yb As Long
    For yo = 1 To rOut.Rows.Count
        For yb = 1 To rOut.Rows.Count
            If yo <> yb Then
                If rOut.Cells(yo, 1).Value = rOut.Cells(yb, 1).Value Then
                    If rOut.Cells(yo, 26).Value > 0 Then
                        If rOut.Cells(yb, 26 + 1).Value >= 0 Then
                            If rOut.Cells(yo, 26).Value <= rOut.Cells(yb, 11).Value - rOut.Cells(yb, 26).Value Then
                                If rOut.Cells(yo, 26).Value < rOut.Cells(yb, 26).Value Then
                                    If rOut.Cells(yb, 26 + 1).Formula = "" Then
                                        rOut.Cells(yb, 26 + 1).Formula = "=" & rOut.Cells(yo, 5).Address(0, 0, xlA1)
                                    Else
                                        rOut.Cells(yb, 26 + 1).Formula = rOut.Cells(yb, 26 + 1).Formula & "+" & rOut.Cells(yo, 5).Address(0, 0, xlA1)
                                    End If
                                    rOut.Cells(yo, 26 + 1).FormulaR1C1 = "=-RC[" & 5 - 26 - 1 & "]"
                                Else
                                    If rOut.Cells(yo, 26 + 1).Formula = "" Then
                                        rOut.Cells(yo, 26 + 1).Formula = "=" & rOut.Cells(yb, 5).Address(0, 0, xlA1)
                                    Else
                                        rOut.Cells(yo, 26 + 1).Formula = rOut.Cells(yo, 26 + 1).Formula & "+" & rOut.Cells(yb, 5).Address(0, 0, xlA1)
                                    End If
                                    rOut.Cells(yb, 26 + 1).FormulaR1C1 = "=-RC[" & 5 - 26 - 1 & "]"
                                End If
                                Exit For
                            End If
                        End If
                    End If
                End If
            End If
        Next
    Next
    
    Set rOut = rOut.Cells(rOut.Rows.Count + 1, 1)
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Option Explicit
 
Sub SendMail_sub()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application") 'запускаем Outlook в скрытом режиме
    OutApp.Session.Logon
    On Error GoTo cleanup  'если не запустился - выходим
    Set OutMail = OutApp.CreateItem(0)   'создаем новое сообщение
    On Error Resume Next
 
    'заполняем поля сообщения
    With OutMail
        .To = Range("A1").Value
        .Subject = Range("A2").Value
        .Body = Range("A3").Value
 
        Dim vFile As Variant
        For Each vFile In CreateObject("Scripting.FileSystemObject").GetFolder(Range("A4").Value).Files
            .Attachments.Add CStr(vFile)
        Next
 
        .Display
        '.Send
    End With
    On Error GoTo 0
    Set OutMail = Nothing
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

    Dim vFile As Variant
    For Each vFile In CreateObject("Scripting.FileSystemObject").GetFolder(Range("A4").Value).Files
        .Attachments.Add vFile
    Next

=6-ЕСЛИОШИБКА(ПОИСКПОЗ(L8+1;СМЕЩ(Лист4!$B$1;ПОИСКПОЗ(K8;Лист4!$B:$B;0)-1;1+3*(E8-1);1;3);-1)+1;1)

Option Explicit

Sub Суммировать_выделенные_ячейки()
    CloseEmptyWb
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    Set rr = Intersect(rr, rr.Cells(1, 1).EntireColumn)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    
    SumRange rr
End Sub

Private Sub SumRange(rr As Range)
    Dim rOut As Range
    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    Application.Calculation = xlCalculationAutomatic
    
    Dim rArea As Range
    For Each rArea In rr.Areas
        SumArea rArea, rOut
    Next
    
    rOut.Parent.Parent.Saved = True
End Sub

Private Sub SumArea(rArea As Range, rOut As Range)
    Set rOut = rOut.Resize(rArea.Rows.Count)
    
    Dim xa As Variant
    For Each xa In Array(1, 5, 9, 11)
        rArea.Columns(xa).Copy rOut.Cells(1, xa).Resize(rArea.Rows.Count)
    Next
    
    rOut.Columns(26).FormulaR1C1 = "=RC[" & 5 - 26 & "]+RC[1]"
    
    Dim yo As Long, yb As Long
    For yo = 1 To rOut.Rows.Count
        For yb = 1 To rOut.Rows.Count
            If yo <> yb Then
                If rOut.Cells(yo, 1).Value = rOut.Cells(yb, 1).Value Then
                    If rOut.Cells(yo, 26).Value > 0 Then
                        If rOut.Cells(yb, 26 + 1).Value >= 0 Then
                            If rOut.Cells(yo, 26).Value <= rOut.Cells(yb, 11).Value - rOut.Cells(yb, 26).Value Then
                                If rOut.Cells(yo, 26).Value < rOut.Cells(yb, 26).Value Then
                                    If rOut.Cells(yb, 26 + 1).Formula = "" Then
                                        rOut.Cells(yb, 26 + 1).Formula = "=" & rOut.Cells(yo, 5).Address(0, 0, xlA1)
                                    Else
                                        rOut.Cells(yb, 26 + 1).Formula = rOut.Cells(yb, 26 + 1).Formula & "+" & rOut.Cells(yo, 5).Address(0, 0, xlA1)
                                    End If
                                    rOut.Cells(yo, 26 + 1).FormulaR1C1 = "=-RC[" & 5 - 26 - 1 & "]"
                                Else
                                    If rOut.Cells(yo, 26 + 1).Formula = "" Then
                                        rOut.Cells(yo, 26 + 1).Formula = "=" & rOut.Cells(yb, 5).Address(0, 0, xlA1)
                                    Else
                                        rOut.Cells(yo, 26 + 1).Formula = rOut.Cells(yo, 26 + 1).Formula & "+" & rOut.Cells(yb, 5).Address(0, 0, xlA1)
                                    End If
                                    rOut.Cells(yb, 26 + 1).FormulaR1C1 = "=-RC[" & 5 - 26 - 1 & "]"
                                End If
                                Exit For
                            End If
                        End If
                    End If
                End If
            End If
        Next
    Next
    
    Set rOut = rOut.Cells(rOut.Rows.Count + 1, 1)
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Option Explicit
'v2
Sub Вывести_среднее()
    CloseEmptyWb
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    Set rr = Intersect(rr, rr.Cells(1).EntireColumn)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    
    Dim aPrint As Variant
    aPrint = GetPrintArray(rr)
    If IsEmpty(aPrint) Then Exit Sub
    
    PrintArray aPrint, rr
End Sub

Private Sub PrintArray(arr As Variant, rTemlate As Range)
    Workbooks.Add
    Dim rr As Range
    Set rr = Sheets(1).Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2))
    rTemlate.EntireColumn.Resize(, rr.Columns.Count).Copy rr.EntireColumn
    rTemlate.Cells(1, 1).Resize(1, rr.Columns.Count).Copy rr
    rr.Resize(rr.Parent.UsedRange.Rows.Count, rr.Parent.UsedRange.Columns.Count).ClearContents
    rr.Cells(rr.Rows.Count + 1, 1).Resize(rr.Parent.UsedRange.Rows.Count, rr.Parent.UsedRange.Columns.Count).Clear
    rr.Value = arr
    Application.Goto rr
    
    rr.Parent.Parent.Saved = True
End Sub

Private Function GetPrintArray(rr As Range) As Variant
    Dim dic As Object
    Set dic = GetDic(rr)
    If dic.Count = 0 Then Exit Function
    
    Dim arr As Variant, brr As Variant
    ReDim arr(1 To dic.Count, 1 To 3)
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        arr(ya, 1) = dic.Keys()(ya - 1)
        brr = dic.Items()(ya - 1)
        arr(ya, 3) = Round(brr(1) / brr(0), 0)
    Next
    GetPrintArray = arr
End Function

Private Function GetDic(rr As Range) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim rArea As Range, arr As Variant, brr As Variant, ya As Long
    For Each rArea In rr.Areas
        arr = rArea.Resize(, 2).Value
        For ya = 1 To UBound(arr, 1)
            If IsNumeric(arr(ya, 2)) Then
                If dic.Exists(arr(ya, 1)) Then
                    brr = dic(arr(ya, 1))
                Else
                    brr = Array(0, 0)
                End If
                brr(0) = brr(0) + 1
                brr(1) = brr(1) + arr(ya, 2)
                dic(arr(ya, 1)) = brr
            End If
        Next
    Next
    Set GetDic = dic
End Function

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

=A2<>A3

=ОКРУГЛ(СУММЕСЛИМН(B:B;A:A;A:A)/СЧЁТЕСЛИМН(A:A;A:A);0)

Option Explicit
Private fso As Object
'v2
Sub Выбрать_файлы()
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
    
    Dim sFolder As String
    sFolder = ShowFolderDialog(aFiles(1))
    If sFolder = "" Then Exit Sub
    sFolder = sFolder & "\"
    
    Application.StatusBar = False
    Dim vFile As Variant
    For Each vFile In aFiles
        myCopyFile vFile, sFolder
    Next
End Sub

Private Sub myCopyFile(ByVal sSource, sFolder As String)
    If HasDate(fso.GetBaseName(sSource)) Then
        Dim sName As String
        sName = GetNewName(fso.GetFileName(sSource))
        If sName <> "" Then
            On Error Resume Next
            fso.CopyFile sSource, sFolder & sName
            If Err = 0 Then Application.StatusBar = Left(Format(Now, "HH:MM:SS") & " Скопирован файл " & sFolder & sName, 255)
            On Error GoTo 0
        End If
    End If
End Sub

Private Function GetNewName(sName As String) As String
    Dim res As String
    Dim ii As Long, ss As String
    For ii = 2 To Len(sName)
        ss = Mid(sName, ii, 4)
        If ss Like " ##-" Or ss Like "_##-" Then
            res = Left(sName, ii - 1)
            res = res & "." & fso.GetExtensionName(sName)
        End If
    Next
    GetNewName = res
End Function

Private Function HasDate(sName As String) As Boolean
    If sName Like "* ##-???-20##" Then
        HasDate = True
    ElseIf sName Like "*_##-???-20##" Then
        HasDate = True
    ElseIf sName Like "* ##-##-20##" Then
        HasDate = True
    ElseIf sName Like "*_##-##-20##" Then
        HasDate = True
    End If
End Function

Private Function ShowFolderDialog(ByVal sBegin As String) As Variant
    Dim oFD As FileDialog
    Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
    With oFD 'используем короткое обращение к объекту
        .AllowMultiSelect = False
        .Title = "Выбрать папку" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
'        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
'        .Filters.Add "All files", "*.*", 2 'добавляем возможность выбора текстовых файлов
'        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = fso.GetParentFolderName(sBegin) & "\"
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        ShowFolderDialog = .SelectedItems(1)
    End With
End Function

Private Function ShowFileDialog() As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim rInitialFileName As Range, sInitialFileName As String
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("SourceFile").RefersToRange
    sInitialFileName = rInitialFileName.Value
    If Left(sInitialFileName, 2) = ".\" Then
        sInitialFileName = Mid(sInitialFileName, 2)
        sInitialFileName = ThisWorkbook.Path & sInitialFileName
    End If
    On Error GoTo 0
    
    Dim oFD As FileDialog
    Dim lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        .Filters.Add "All files", "*.*", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = sInitialFileName
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant, sName As String
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            sName = fso.GetFileName(.SelectedItems(lf))
            If Left(sName, 2) <> "~$" Then
                If sName <> ThisWorkbook.Name Then
                    If IsEmpty(arr) Then
                        ReDim arr(1 To 1)
                        If Not rInitialFileName Is Nothing Then
                            sInitialFileName = .SelectedItems(lf)
                            sInitialFileName = Replace(sInitialFileName, ThisWorkbook.Path, ".")
                            rInitialFileName.Value = sInitialFileName
                        End If
                    Else
                        ReDim Preserve arr(1 To UBound(arr) + 1)
                    End If
                    arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
                End If
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

=ЕСЛИОШИБКА(РАЗНДАТ(МАКС(ДАТА(ГОД(F5);1;1);E5);F5;"M");"")

Sub Сохранить_файл()
    Работа
    SaveSheet ActiveSheet, Range("A1").Value
End Sub

или

Sub Работа()
...

' закрыть файл
'      Application.Quit

Сохранить_файл
End Sub

=ЕСЛИОШИБКА(РАЗНДАТ(E5;F5;"M");0)
=ЕСЛИ(G5<6;0;ЕСЛИ(G5<9;0,5;ЕСЛИ(G5<11;0,8;1)))

=ЕСЛИОШИБКА(РАЗНДАТ(МАКС(ДАТА(ГОД(F5);1;1);E5);F5;"M");"")

=ЕСЛИОШИБКА(РАЗНДАТ(E5;F5;"M");"")

Option Explicit
'v2
Public fso As Object
 
Sub Сохранить_файл()
    SaveSheet ActiveSheet, Range("A1").Value
End Sub
 
Private Sub SaveSheet(sh As Worksheet, ByVal cityName As String)
    Application.StatusBar = False
    If Not sh.Name Like "##-##-20##" Then
        MsgBox "Имя листа " & sh.Name & Chr(10) & "не соответствует маске ДД-ММ-ГГГГ.", vbCritical, "Имя листа"
        Exit Sub
    End If
     
    Set fso = CreateObject("Scripting.FileSystemObject")
     
    Dim dt As Date
    dt = sh.Name
     
    Dim sFull As String
    ReplaceSymbols cityName
    cityName = Left(cityName, 32)
    If cityName = "" Then
        MsgBox "Проверьте название " & cityName, vbCritical, "Название"
        Exit Sub
    End If
     
    Dim wb As Workbook
    Set wb = sh.Parent
     
    sFull = "C:\Отчеты\" & cityName & "\" & Format(dt, "MM") & "\" & cityName & "-" & Format(dt, "YYYY-MM-DD") & "." & fso.GetExtensionName(wb.Name)
    myCreateFolder fso.GetParentFolderName(sFull)
     
    On Error Resume Next
    Workbooks(fso.GetFileName(sFull)).Close False
    Kill sFull
    Err.Clear
    wb.SaveCopyAs sFull
     
    If Err = 0 Then
        Application.StatusBar = Left(Format(Now, "hh:mm:ss") & " Сохранён файл " & sFull, 255)
    Else
        MsgBox Err.Description, vbCritical, "Ошибка сохранения"
    End If
    On Error GoTo 0
     
End Sub
 
Private Sub ReplaceSymbols(ss As String)
    Dim vv As Variant
    For Each vv In Array("\", "/", ":", "*", "?", """", "<", ">", "|", "[", "]") '[] недопустимые только в имени листа
        ss = Replace(ss, vv, " ")
    Next
    ss = Trim(ss) 'Пробел в конце строки не распознаётся файловой системой.
End Sub
 
Private Sub myCreateFolder(sPath As String)
    If sPath = "" Then Exit Sub
    Dim arr As Variant
    arr = Split(sPath, "\")
     
    Dim ii As Long
    Dim i1 As Long
    For ii = LBound(arr) + 1 To UBound(arr)
        arr(ii) = arr(ii - 1) & "\" & arr(ii)
        If fso.FolderExists(arr(ii)) Then i1 = ii
    Next
    For ii = i1 + 1 To UBound(arr)
        fso.CreateFolder arr(ii)
    Next
End Sub

Option Explicit
Public fso As Object

Sub Сохранить_файл()
    SaveSheet ActiveSheet, Range("A1").Value
End Sub

Private Sub SaveSheet(sh As Worksheet, ByVal cityName As String)
    Application.StatusBar = False
    If Not sh.Name Like "##-##-20##" Then
        MsgBox "Имя листа " & sh.Name & Chr(10) & "не соответствует маске ДД-ММ-ГГГГ.", vbCritical, "Имя листа"
        Exit Sub
    End If
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim dt As Date
    dt = sh.Name
    
    Dim sFull As String
    ReplaceSymbols cityName
    cityName = Left(cityName, 32)
    If cityName = "" Then
        MsgBox "Проверьте название " & cityName, vbCritical, "Название"
        Exit Sub
    End If
    
    Dim wb As Workbook
    Set wb = sh.Parent
    
    sFull = "C:\Отчеты\" & Format(dt, "MM") & "\" & cityName & "-" & Format(dt, "YYYY-MM-DD") & "." & fso.GetExtensionName(wb.Name)
    myCreateFolder fso.GetParentFolderName(sFull)
    
    On Error Resume Next
    Workbooks(fso.GetFileName(sFull)).Close False
    Kill sFull
    Err.Clear
    wb.SaveCopyAs sFull
    
    If Err = 0 Then
        Application.StatusBar = Left(Format(Now, "hh:mm:ss") & " Сохранён файл " & sFull, 255)
    Else
        MsgBox Err.Description, vbCritical, "Ошибка сохранения"
    End If
    On Error GoTo 0
    
End Sub

Private Sub ReplaceSymbols(ss As String)
    Dim vv As Variant
    For Each vv In Array("\", "/", ":", "*", "?", """", "<", ">", "|", "[", "]") '[] недопустимые только в имени листа
        ss = Replace(ss, vv, " ")
    Next
    ss = Trim(ss) 'Пробел в конце строки не распознаётся файловой системой.
End Sub

Private Sub myCreateFolder(sPath As String)
    If sPath = "" Then Exit Sub
    Dim arr As Variant
    arr = Split(sPath, "\")
    
    Dim ii As Long
    Dim i1 As Long
    For ii = LBound(arr) + 1 To UBound(arr)
        arr(ii) = arr(ii - 1) & "\" & arr(ii)
        If fso.FolderExists(arr(ii)) Then i1 = ii
    Next
    For ii = i1 + 1 To UBound(arr)
        fso.CreateFolder arr(ii)
    Next
End Sub

Option Explicit
'v4
Sub Сверка()
    Dim sh As Worksheet
    Set sh = ActiveSheet
    
    sh.Columns(4).ClearContents
    sh.Columns(5).ClearContents
    sh.Columns(10).Resize(, sh.UsedRange.Columns.Count).ClearContents
    
    Application.Calculation = xlCalculationAutomatic
    
    Dim ya As Long, yb As Long, xb As Long
    For ya = 2 To sh.UsedRange.Rows.Count
        If IsDate(sh.Cells(ya, 1).Value) Then
            If IsDate(sh.Cells(ya, 2).Value) Then
                sh.Cells(ya, 5).FormulaR1C1 = "=RC[-2]-RC[-1]"
                For yb = 2 To sh.UsedRange.Rows.Count
                    If sh.Cells(ya, 5).Value <= 0 Then Exit For
                    If IsDate(sh.Cells(yb, 8).Value) Then
                        If IsEmpty(sh.Cells(yb, 10)) Then sh.Cells(yb, 10).FormulaR1C1 = "=RC[-1]-RC[1]"
                        If IsEmpty(sh.Cells(yb, 11)) Then sh.Cells(yb, 11).FormulaR1C1 = "=SUM(RC[1]:RC16384)"
                        If sh.Cells(yb, 8).Value >= sh.Cells(ya, 1).Value Then
                            If sh.Cells(yb, 8).Value <= sh.Cells(ya, 2).Value Then
                                If sh.Cells(yb, 10).Value > 0 Then
                                    xb = 12
                                    Do
                                        If IsEmpty(sh.Cells(yb, xb)) Then Exit Do
                                        xb = xb + 1
                                        DoEvents
                                    Loop
                                    sh.Cells(yb, xb).Value = WorksheetFunction.Round(WorksheetFunction.Min(sh.Cells(yb, 10).Value, sh.Cells(ya, 5).Value), 2)
                                    sh.Cells(ya, 4).Formula = IIf(sh.Cells(ya, 4).Formula = "", "=", sh.Cells(ya, 4).Formula & "+") & sh.Cells(yb, xb).Address(0, 0, xlA1)
                                End If
                            End If
                        End If
                    End If

'                    If sh.Cells(yb, 10).Value < sh.Cells(yb, 9).Value Then
'                        If IsDate(sh.Cells(yb, 8).Value) Then
'                            If sh.Cells(yb, 8).Value >= sh.Cells(ya, 1).Value Then
'                                If sh.Cells(yb, 8).Value <= sh.Cells(ya, 2).Value Then
'                                    If sh.Cells(yb, 9).Value + sh.Cells(ya, 4).Value <= sh.Cells(ya, 3).Value Then
'                                        sh.Cells(ya, 4).Formula = IIf(sh.Cells(ya, 4).Formula = "", "=", sh.Cells(ya, 4).Formula & "+") & sh.Cells(yb, 9).Address(0, 0, xlA1)
'                                        sh.Cells(yb, 10).Value = sh.Cells(yb, 9).Value
'                                    End If
'                                End If
'                            End If
'                        End If
'                    End If
                Next
            End If
        End If
    Next
End Sub

'v3
Sub Сверка()
    Dim sh As Worksheet
    Set sh = ActiveSheet
    
    sh.Columns(4).ClearContents
    sh.Columns(5).ClearContents
    sh.Columns(10).ClearContents
    
    Application.Calculation = xlCalculationAutomatic
    
    Dim ya As Long, yb As Long
    For ya = 2 To sh.UsedRange.Rows.Count
        If IsDate(sh.Cells(ya, 1).Value) Then
            If IsDate(sh.Cells(ya, 2).Value) Then
                For yb = 2 To sh.UsedRange.Rows.Count
                    If sh.Cells(yb, 10).Value < sh.Cells(yb, 9).Value Then
                        If IsDate(sh.Cells(yb, 8).Value) Then
                            If sh.Cells(yb, 8).Value >= sh.Cells(ya, 1).Value Then
                                If sh.Cells(yb, 8).Value <= sh.Cells(ya, 2).Value Then
                                    If sh.Cells(yb, 9).Value + sh.Cells(ya, 4).Value <= sh.Cells(ya, 3).Value Then
                                        sh.Cells(ya, 4).Formula = IIf(sh.Cells(ya, 4).Formula = "", "=", sh.Cells(ya, 4).Formula & "+") & sh.Cells(yb, 9).Address(0, 0, xlA1)
                                        sh.Cells(yb, 10).Value = sh.Cells(yb, 9).Value
                                        sh.Cells(ya, 5).FormulaR1C1 = "=RC[-2]-RC[-1]"
                                        If sh.Cells(ya, 5).Value <= 0 Then Exit For
                                    End If
                                End If
                            End If
                        End If
                    End If
                Next
            End If
        End If
    Next
End Sub

'v2
Sub Сверка()
    Dim sh As Worksheet
    Set sh = ActiveSheet
    
    sh.Columns(4).ClearContents
    sh.Columns(5).ClearContents
    sh.Columns(10).ClearContents
    
    Application.Calculation = xlCalculationAutomatic
    
    Dim ya As Long, yb As Long
    For ya = 2 To sh.UsedRange.Rows.Count
        If IsDate(sh.Cells(ya, 1).Value) Then
            If IsDate(sh.Cells(ya, 2).Value) Then
                For yb = 2 To sh.UsedRange.Rows.Count
                    If sh.Cells(yb, 10).Value < sh.Cells(ya, 9).Value Then
                        If IsDate(sh.Cells(yb, 8).Value) Then
                            If sh.Cells(yb, 8).Value >= sh.Cells(ya, 1).Value Then
                                If sh.Cells(yb, 8).Value <= sh.Cells(ya, 2).Value Then
                                    If sh.Cells(yb, 9).Value + sh.Cells(ya, 4).Value <= sh.Cells(ya, 3).Value Then
                                        sh.Cells(ya, 4).Formula = IIf(sh.Cells(ya, 4).Formula = "", "=", "") & sh.Cells(ya, 4).Formula & "+" & sh.Cells(yb, 9).Address(0, 0, xlA1)
                                        sh.Cells(yb, 10).Value = sh.Cells(yb, 9).Value
                                        sh.Cells(ya, 5).FormulaR1C1 = "=RC[-2]-RC[-1]"
                                    End If
                                End If
                            End If
                        End If
                    End If
                Next
            End If
        End If
    Next
End Sub

Sub DelShapes()
    Dim ss As Shape
    For Each ss In ActiveSheet.Shapes
        ss.Delete
    Next
End Sub