=ВПР(A2;ДВССЫЛ(B11&"B2:E5");4;0)

=D5

=$D10-(СУММ($E$4:E$4))

=МАКС(0;D10)-МАКС(0;E10)

Function СуммДДУ(CheckRange As Range, SampleCell As Range) As Long
    Dim cell As Range
    Dim count As Long
    Dim sampleColor As Long
    Dim sampleText As String
    
    ' Получаем цвет заливки и текст эталонной ячейки B2
    sampleColor = SampleCell.Interior.Color
    sampleText = CStr(SampleCell.Value)
    
    count = 0
    
    ' Перебираем каждую ячейку в диапазоне A1:A10
    For Each cell In CheckRange
        ' Проверяем совпадение цвета заливки И текста
        If cell.Interior.Color = sampleColor And (InStr(1, CStr(cell.Value), sampleText, vbTextCompare) > 0) Then '           <- ТУТ
            count = count + 1
        End If
    Next cell
    
    СуммДДУ = count
End Function

=СЖПРОБЕЛЫ(ПРАВСИМВ(ПОДСТАВИТЬ(A1;" ";ПОВТОР(" ";СТЕПЕНЬ(10;ЦЕЛОЕ(LOG10(ДЛСТР(A1)))+1)));2*СТЕПЕНЬ(10;ЦЕЛОЕ(LOG10(ДЛСТР(A1)))+1)))

=СЖПРОБЕЛЫ(ПРАВСИМВ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(A1;СИМВОЛ(160);" ");" ";ПОВТОР(" ";СТЕПЕНЬ(10;ЦЕЛОЕ(LOG10(ДЛСТР(A1)))+1)));2*СТЕПЕНЬ(10;ЦЕЛОЕ(LOG10(ДЛСТР(A1)))+1)))

=ЕСЛИОШИБКА(ЕСЛИОШИБКА(ВПР(C2;$X$3:$Z$7;2;0);ВПР(B2;$X$4:$Z$5;3;0));"")

            DeleteNames_IL_PR wb 'копировать формулы без деспетчера имён->продолжене см. Private Sub DeleteNames
            ThisWorkbook.Worksheets("Информация_ИЛ").Cells.Copy wb.Worksheets("Информация_ИЛ").Cells 'копируем все данные с листа
            DeleteNames_IL_PR wb 'копировать формулы без деспетчера имён->продолжене см. Private Sub DeleteNames

Set wb = Workbooks.Open(iCl.Value)
DeleteNames wb
...
End Sub

Private Sub DeleteNames(wb As Workbook)
    On Error Resume Next
    Dim nn As Name
    For Each nn In wb.Names
        nn.Delete
    Next
    On Error GoTo 0
End Sub

Private Function sInitialFileName() As String
    sInitialFileName = ThisWorkbook.Sheets("Прог").Range("G12").Value
    If Right(sInitialFileName, 1) <> "\" Then sInitialFileName = sInitialFileName & "\"
End Function

=СУММЕСЛИМН(Лист1!C:C;Лист1!$A:$A;$A:$A)

Set wb = Workbooks.Open(iPath & iCl.Value)

Set wb = Workbooks.Open(iCl.Value)

Option Explicit

Sub Преобразовать_активный_лист()
    CloseEmptyWb ""
    RangeJob ActiveSheet.UsedRange, Workbooks.Add(1).Sheets(1).Cells(1, 1)
End Sub

Private Sub RangeJob(rSource As Range, rTarget As Range)
'    Application.ScreenUpdating = False
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    CloseEmptyWb rTarget.Parent.Parent.Name
        
    Dim ys As Long, ii As Long
    For ys = 1 To rSource.Rows.Count
        If ii < rSource.Rows(ys).OutlineLevel Then ii = rSource.Rows(ys).OutlineLevel
    Next
    If ii = 0 Then Exit Sub
    
    Dim arr As Variant, xt As Long, xs As Long, jj As Long
    ReDim arr(1 To ii)
    
    For ys = 1 To rSource.Rows.Count
        ii = rSource.Rows(ys).OutlineLevel
        arr(ii) = rSource.Cells(ys, 1).Value
        For jj = ii + 1 To UBound(arr)
            arr(jj) = Empty
        Next
        
        xt = 0
        For ii = 1 To UBound(arr)
            xt = xt + 1
            rTarget.Cells(ys, xt).Value = arr(xt)
        Next
        xs = 1
        Do
            With rSource.Cells(ys, xs).MergeArea
                xs = .Column + .Columns.Count
            End With
            If xs > rSource.Columns.Count Then Exit Do
            
            xt = xt + 1
            rTarget.Cells(ys, xt).Value = rSource.Cells(ys, xs).Value
            
            DoEvents
        Loop
    Next
    rTarget.Parent.UsedRange.EntireColumn.AutoFit

    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
End Sub

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

=ПОДСТАВИТЬ(СТРОЧН(ТЕКСТ(ДАТАЗНАЧ(E2&" "&ПОДСТАВИТЬ(H2;"ября";"ябрь")&" "&M2)+1;"ММММ"));"ябрь";"ября")

=ЗНАЧЕН(ТЕКСТ(ДАТАЗНАЧ(E2&" "&ПОДСТАВИТЬ(H2;"ября";"ябрь")&" "&M2)+1;"ГГГГ"))

=ЗНАЧЕН(ТЕКСТ(ДАТАЗНАЧ(E2&" "&ПОДСТАВИТЬ(H2;"ября";"ябрь")&" "&M2)+1;"ДД"))

Вместо
If cd.Row - 1 <= rr.Row + nRows Then Exit Do
Напишите
If cd.Row <= rr.Row + nRows Then Exit Do

Option Explicit
 
Sub Копировать_значения_только_в_путь_в_определенной_ячейки()
    Dim rSheets As Range, journalFullname As String, sourceRange As Range
    Set rSheets = ThisWorkbook.Sheets("Подборка").UsedRange.Rows(1)
    journalFullname = ThisWorkbook.Sheets("Расположение").Range("G4").Value
    Set sourceRange = ThisWorkbook.Sheets("Данные").UsedRange
     
    CopyRange rSheets, journalFullname, sourceRange
End Sub
 
Private Sub CopyRange(rSheets As Range, journalFullname As String, sourceRange As Range)
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
     
    Dim journal As Workbook
    On Error Resume Next
    Set journal = Workbooks.Open(journalFullname)
    If journal Is Nothing Then
        MsgBox Err.Description, vbExclamation, "Ошибка открытия файла"
    End If
    On Error GoTo 0
    If Not journal Is Nothing Then
        Set rSheets = Intersect(rSheets, rSheets.Parent.UsedRange)
        Set sourceRange = Intersect(sourceRange, sourceRange.Parent.Range("A3").Resize(sourceRange.Parent.UsedRange.Rows.Count, sourceRange.Parent.UsedRange.Columns.Count))
         
        CopyJournal rSheets, journal, sourceRange
        Application.Calculation = Application_Calculation
         
        journal.Close True
    Else
        Application.Calculation = Application_Calculation
    End If
End Sub
 
Private Sub CopyJournal(rSheets As Range, journal As Workbook, sourceRange As Range)
    Dim clSheet As Range, shTarget As Worksheet, rTarget As Range
    For Each clSheet In rSheets.Cells
        On Error Resume Next
        Set shTarget = journal.Worksheets(clSheet.Value)
        On Error GoTo 0
        If Not shTarget Is Nothing Then
            Set rTarget = GetTargetRange(shTarget, sourceRange)
            Set rTarget = rTarget.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
            sourceRange.Copy rTarget
            Application.CutCopyMode = False
            rTarget.Value = sourceRange.Value
             
            Set shTarget = Nothing
        End If
    Next
End Sub
 
Private Function GetTargetRange(sh As Worksheet, sourceRange As Range) As Range
    Set GetTargetRange = GetTargetRange_Exists(sh, sourceRange)
    If Not GetTargetRange Is Nothing Then Exit Function
    Set GetTargetRange = GetTargetRange_New(sh)
End Function

Private Function GetTargetRange_Exists(sh As Worksheet, sourceRange As Range) As Range
    Dim yy As Long
    For yy = 2 To sh.UsedRange.Rows.Count
        If sh.Cells(yy, 1).Value = sourceRange.Cells(1, 1).Value Then
        If sh.Cells(yy, 2).Value = sourceRange.Cells(1, 2).Value Then
        If sh.Cells(yy, 3).Value = sourceRange.Cells(1, 3).Value Then
            Set GetTargetRange_Exists = sh.Cells(yy, 1)
            AddRows sh.Cells(yy, 1), sourceRange.Rows.Count
            Exit Function
        End If
        End If
        End If
    Next
End Function

Private Sub AddRows(rr As Range, nRows As Long)
    Dim sh As Worksheet
    Set sh = rr.Parent
    
    Dim cd As Range
    Set cd = rr.End(xlDown)
    If cd.Row >= sh.Rows.Count - 2 Then Exit Sub
    
    Do
        If cd.Row >= rr.Row + nRows Then Exit Do
        cd.EntireRow.Insert
        DoEvents
    Loop
    
    Do
        If cd.Row - 1 <= rr.Row + nRows Then Exit Do
        cd.Cells(0, 1).EntireRow.Delete
        DoEvents
    Loop
End Sub

Private Function GetTargetRange_New(sh As Worksheet) As Range
    Dim cl As Range, yy As Long, ym As Long
    ym = 1
    For Each cl In sh.UsedRange.Rows(sh.UsedRange.Rows.Count + 2).Cells
        yy = cl.End(xlUp).Row + 1
        If ym < yy Then ym = yy
    Next
    Set GetTargetRange_New = sh.Cells(ym, 1)
End Function

=ОКРУГЛ(0,5*(E10+0,5)-5,5;0)

Option Explicit
 
Sub Копировать_значения_только_в_путь_в_определенной_ячейки()
    Dim rSheets As Range, journalFullname As String, sourceRange As Range
    Set rSheets = ThisWorkbook.Sheets("Подборка").UsedRange.Rows(1)
    journalFullname = ThisWorkbook.Sheets("Расположение").Range("G4").Value
    Set sourceRange = ThisWorkbook.Sheets("Данные").UsedRange
     
    CopyRange rSheets, journalFullname, sourceRange
End Sub
 
Private Sub CopyRange(rSheets As Range, journalFullname As String, sourceRange As Range)
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
     
    Dim journal As Workbook
    On Error Resume Next
    Set journal = Workbooks.Open(journalFullname)
    If journal Is Nothing Then
        MsgBox Err.Description, vbExclamation, "Ошибка открытия файла"
    End If
    On Error GoTo 0
    If Not journal Is Nothing Then
        Set rSheets = Intersect(rSheets, rSheets.Parent.UsedRange)
        Set sourceRange = Intersect(sourceRange, sourceRange.Parent.Range("A3").Resize(sourceRange.Parent.UsedRange.Rows.Count, sourceRange.Parent.UsedRange.Columns.Count))
         
        CopyJournal rSheets, journal, sourceRange
        Application.Calculation = Application_Calculation
         
        journal.Close True
    Else
        Application.Calculation = Application_Calculation
    End If
End Sub
 
Private Sub CopyJournal(rSheets As Range, journal As Workbook, sourceRange As Range)
    Dim clSheet As Range, shTarget As Worksheet, rTarget As Range
    For Each clSheet In rSheets.Cells
        On Error Resume Next
        Set shTarget = journal.Worksheets(clSheet.Value)
        On Error GoTo 0
        If Not shTarget Is Nothing Then
            Set rTarget = GetTargetRange(shTarget, sourceRange)
            Set rTarget = rTarget.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
            sourceRange.Copy rTarget
            Application.CutCopyMode = False
            rTarget.Value = sourceRange.Value
             
            Set shTarget = Nothing
        End If
    Next
End Sub
 
Private Function GetTargetRange(sh As Worksheet, sourceRange As Range) As Range
    Set GetTargetRange = GetTargetRange_Exists(sh, sourceRange)
    If Not GetTargetRange Is Nothing Then Exit Function
    Set GetTargetRange = GetTargetRange_New(sh)
End Function

Private Function GetTargetRange_Exists(sh As Worksheet, sourceRange As Range) As Range
    Dim yy As Long
    For yy = 2 To sh.UsedRange.Rows.Count
        If sh.Cells(yy, 1).Value = sourceRange.Cells(1, 1).Value Then
        If sh.Cells(yy, 2).Value = sourceRange.Cells(1, 2).Value Then
        If sh.Cells(yy, 3).Value = sourceRange.Cells(1, 3).Value Then
            Set GetTargetRange_Exists = sh.Cells(yy, 1)
            Exit Function
        End If
        End If
        End If
    Next
End Function

Private Function GetTargetRange_New(sh As Worksheet) As Range
    Dim cl As Range, yy As Long, ym As Long
    ym = 1
    For Each cl In sh.UsedRange.Rows(sh.UsedRange.Rows.Count + 2).Cells
        yy = cl.End(xlUp).Row + 1
        If ym < yy Then ym = yy
    Next
    Set GetTargetRange_New = sh.Cells(ym, 1)
End Function

Option Explicit

Sub Напечатать_протоколы()
    CloseEmptyWb
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    
    Dim protocols As Object
    Set protocols = GetProtocols(wb.Sheets("Данные"))
    
    Dim protocol_index As Long
    For protocol_index = 1 To protocols.Count - 1
        PrintProtocol protocols, protocol_index, wb.Sheets("Прот")
    Next
End Sub

Private Sub PrintProtocol(protocols As Object, protocol_index As Long, shTemplate As Worksheet)
    shTemplate.Copy
    Dim sh As Worksheet
    Set sh = ActiveSheet
    
    sh.Cells(4, 20).Value = protocols.Keys()(protocol_index)
    
    Dim aHead As Variant, aValu As Variant
    aHead = protocols.Items()(0).Items()(0)
    aValu = protocols.Items()(protocol_index).Items()
    
    Dim yy As Long
    For yy = 0 To UBound(aValu, 1)
        If yy >= 10 Then
            sh.Rows(28 + yy - 1).Copy
            sh.Rows(28 + yy - 1).Insert Shift:=xlDown
            Application.CutCopyMode = False
            sh.Cells(28 + yy, 1).Value = (yy + 1) & "."
        End If
        sh.Cells(28 + yy, 3).Value = aValu(yy)(1, 1)
        sh.Cells(28 + yy, 16).Value = aValu(yy)(1, 2)
        sh.Cells(28 + yy, 23).Value = aValu(yy)(1, 3)
        sh.Cells(28 + yy, 31).Value = aValu(yy)(1, 4)
        sh.Cells(28 + yy, 37).Value = aValu(yy)(1, 5)
    Next
    sh.PrintOut
End Sub

Private Function GetProtocols(sh As Worksheet) As Object
    Dim rr As Range
    Set rr = sh.Cells(1, 1).Resize(sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1, sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1)
    
    Dim rp As Range
    Set rp = rr.Find("Номер протокола")
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long, bic As Object, vv As Variant
    For ya = rp.Row To rr.Rows.Count
        vv = rr.Cells(ya, rp.Column).Value
        If Not dic.Exists(vv) Then
            Set dic.Item(vv) = CreateObject("Scripting.Dictionary")
        End If
        Set bic = dic.Item(vv)
        bic.Item(bic.Count) = rr.Cells(ya, 1).Resize(1, rr.Columns.Count).Value
        Set dic.Item(vv) = bic
        Set bic = Nothing
    Next
    Set GetProtocols = 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

=ЕСЛИ(И(ОСТАТ(СЧЁТЕСЛИМН($A$1:$A2;"<>")-1;7)+1=B$1;$A2<>"");$A2;"")