Sub make_prot()
    Const PROT_NAME = "ПРОТОКОЛ"
    
    Dim wb As Workbook
    Set wb = ThisWorkbook ' alias
    
    Dim DA As Boolean
    DA = Application.DisplayAlerts
    Application.DisplayAlerts = False
    On Error Resume Next
    wb.Sheets(PROT_NAME).Delete ' убили старый протокол
    On Error GoTo 0
    Application.DisplayAlerts = DA
     
    Dim ptr As Worksheet: Set ptr = wb.Sheets.Add(After:=wb.Sheets("ОТЧЕТ")) ' лист пересоздали.
    ptr.Name = "ПРОТОКОЛ": ptr.Cells.NumberFormat = "@"
    '
    ' тут пока неважно... пока всё хорошо
    '
    ' а тут начинается интересное
    Dim cmp As Object
    'Application.VBE.MainWindow.Visible = True
    With wb.VBProject.VBComponents: End With
    Set cmp = wb.VBProject.VBComponents(ptr.CodeName).CodeModule
      
    cmp.CreateEventProc "BeforeDoubleClick", "Worksheet"
    Dim lm As Long
    lm = cmp.ProcStartLine("Worksheet_BeforeDoubleClick", 0) + 2
    cmp.InsertLines lm, "Cancel = True"
    cmp.InsertLines lm, "MsgBox ""Ты дважды кликнул."", vbInformation, ""Капитан очевидность сообщает..."""
    
    Application.VBE.MainWindow.Visible = False
    VBEshow "make_prot"
End Sub

Sub VBEshow(ProcName As String, Optional ByRef wb As Workbook = Nothing)
    If wb Is Nothing Then Set wb = ThisWorkbook
    
    Application.WindowState = xlMinimized
    Application.VBE.MainWindow.Visible = True
    Application.VBE.MainWindow.SetFocus
    
    Dim Component As Object
    
    For Each Component In wb.VBProject.VBComponents
        With Component.CodeModule
            On Error Resume Next
                With .ProcStartLine(ProcName, 0): End With
                If Err = 0 Then
                    .CodePane.Show
                    .CodePane.SetSelection .ProcBodyLine(ProcName, 0), 1, .ProcBodyLine(ProcName, 0) + 1, 1 ' _
                                            '.ProcStartLine(ProcName, 0) + .ProcCountLines(ProcName, 0), 1  'Выделить всю процедуру
                    Exit Sub
                End If
            On Error GoTo 0
        End With
    Next
End Sub

Sub make_prot()
'v4
    Const PROT_NAME = "ПРОТОКОЛ"
    
    Dim wb As Workbook
    Set wb = ThisWorkbook ' alias
    
    Dim DA As Boolean
    DA = Application.DisplayAlerts
    Application.DisplayAlerts = False
    On Error Resume Next
    wb.Sheets(PROT_NAME).Delete ' убили старый протокол
    On Error GoTo 0
    Application.DisplayAlerts = DA
     
    Dim ptr As Worksheet: Set ptr = wb.Sheets.Add(After:=wb.Sheets("ОТЧЕТ")) ' лист пересоздали.
    ptr.Name = "ПРОТОКОЛ": ptr.Cells.NumberFormat = "@"
    '
    ' тут пока неважно... пока всё хорошо
    '
    ' а тут начинается интересное
    Dim cmp As Object
    Application.VBE.MainWindow.Visible = True
    Set cmp = wb.VBProject.VBComponents(ptr.CodeName).CodeModule
      
    cmp.CreateEventProc "BeforeDoubleClick", "Worksheet"
    Dim lm As Long
    lm = cmp.ProcStartLine("Worksheet_BeforeDoubleClick", 0) + 2
    cmp.InsertLines lm, "Cancel = True"
    cmp.InsertLines lm, "MsgBox ""Ты дважды кликнул."", vbInformation, ""Капитан очевидность сообщает..."""
    
    Application.VBE.MainWindow.Visible = False
End Sub

Sub make_prot()
'v3
    Const PROT_NAME = "ПРОТОКОЛ"
    
    Dim wb As Workbook
    Set wb = ThisWorkbook ' alias
     
'    DA = Application.DisplayAlerts
    Application.DisplayAlerts = False
    On Error Resume Next
    wb.Sheets(PROT_NAME).Delete ' убили старый протокол
    On Error GoTo 0
    Application.DisplayAlerts = True
     
    Dim ptr As Worksheet: Set ptr = wb.Sheets.Add(After:=wb.Sheets("ОТЧЕТ")) ' лист пересоздали.
    ptr.Name = "ПРОТОКОЛ": ptr.Cells.NumberFormat = "@"
    '
    ' тут пока неважно... пока всё хорошо
    '
    ' а тут начинается интересное
    Dim cmp As Object
    Set cmp = wb.VBProject.VBComponents(ptr.CodeName)
      
    cmp.CodeModule.CreateEventProc "BeforeDoubleClick", "Worksheet"
    Dim lm As Long
    lm = cmp.CodeModule.ProcStartLine("Worksheet_BeforeDoubleClick", 0) + 2
    With cmp.CodeModule
        .InsertLines lm, "Cancel = True"
        .InsertLines lm, "MsgBox ""Ты дважды кликнул."", vbInformation, ""Капитан очевидность сообщает..."""
    End With
    
    Application.VBE.MainWindow.Visible = False
End Sub

Sub make_prot()
'v2
    Const PROT_NAME = "ПРОТОКОЛ"
    
    Dim wb As Workbook
    Set wb = ThisWorkbook ' alias
     
'    DA = Application.DisplayAlerts
    Application.DisplayAlerts = False
    On Error Resume Next
    wb.Sheets(PROT_NAME).Delete ' убили старый протокол
    On Error GoTo 0
    Application.DisplayAlerts = True
     
    Dim ptr As Worksheet: Set ptr = wb.Sheets.Add(After:=wb.Sheets("ОТЧЕТ")) ' лист пересоздали.
    ptr.Name = "ПРОТОКОЛ": ptr.Cells.NumberFormat = "@"
    '
    ' тут пока неважно... пока всё хорошо
    '
    ' а тут начинается интересное
    Dim prj As Object, cmp As Object
    Set prj = wb.VBProject
    Set cmp = prj.VBComponents(ptr.CodeName)
      
    cmp.CodeModule.CreateEventProc "BeforeDoubleClick", "Worksheet"
    Dim lm As Long
    lm = cmp.CodeModule.ProcStartLine("Worksheet_BeforeDoubleClick", 0) + 2
    With cmp.CodeModule
        .InsertLines lm, "Cancel = True"
        .InsertLines lm, "MsgBox ""Ты дважды кликнул."", vbInformation, ""Капитан очевидность сообщает..."""
    End With
End Sub

Sub make_prot()
    Const PROT_NAME = "ПРОТОКОЛ"

    Dim wb As Workbook
    Set wb = ThisWorkbook ' alias
     
'    DA = Application.DisplayAlerts
    Application.DisplayAlerts = False
    On Error Resume Next
    wb.Sheets(PROT_NAME).Delete ' убили старый протокол
    On Error GoTo 0
    Application.DisplayAlerts = True
     
    Dim ptr As Worksheet: Set ptr = wb.Sheets.Add(After:=wb.Sheets("ОТЧЕТ")) ' лист пересоздали.
    ptr.Name = "ПРОТОКОЛ": ptr.Cells.NumberFormat = "@"
    '
    ' тут пока неважно... пока всё хорошо
    '
    ' а тут начинается интересное
    Dim prj As Object, cmp As Object
    Set prj = wb.VBProject
    Set cmp = prj.VBComponents(ptr.CodeName)
      
    With cmp.CodeModule
        Dim lm As Long
        lm = .CreateEventProc("BeforeDoubleClick", "Worksheet")
        .InsertLines lm + 1, "Cancel = True"
        .InsertLines lm + 2, "msgbox ""лист создан"""
        ' и т.д.
    End With
    
End Sub

=СУММЕСЛИМН('Системные события'!$O:$O;'Системные события'!$D:$D;$B:$B;'Системные события'!$L:$L;$3:$3)

=СУММ(($L2=$A$2:$A$11)*($B$2:$B$11<=$M2)*($C$2:$C$11>=$M2)*(N$1=$D$1:$H$1)*ЕСЛИОШИБКА(1/1/$D$2:$H$11;0))

Sub Workbook_Open()
    Range("B4").FormulaLocal = Range("C4").Value
End Sub

ЕСЛИ(B2>10;1;0)

="="&[Данные.xlsx]Лист1!$C$4

Sub FillFormula()
    Range("B4").FormulaLocal = Range("C4").Value
End Sub

Option Explicit
Private WithEvents App As Application

Private Sub Workbook_Open()
    Set App = Excel.Application
End Sub

Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Target.EntireRow.Interior.Color = RGB(200, 255, 200)
End Sub

=СЧЁТЕСЛИМН(СМЕЩ($I$2;ПОИСКПОЗ($A3;$I$3:$I$7;0);1;1;2);$B3)=0

Sub Расход_все_листы()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Sheets
        ExpenseSheet sh
    Next
End Sub

Private Sub ExpenseSheet(sh As Worksheet)
    Const TARG_ADR = "M26"
    Const SOUR_ADR = "N26"
    If sh.Range(TARG_ADR).Cells(0, 1).Value <> "Сутки" Then Exit Sub
    
    If Not IsDate(sh.Name) Then Exit Sub
    Dim shNext As Worksheet
    On Error Resume Next
    Set shNext = sh.Parent.Sheets(Format(CDate(sh.Name) + 1, "dd.mm.yyyy"))
    On Error GoTo 0
    If shNext Is Nothing Then Exit Sub
    sh.Range(TARG_ADR).Formula = "='" & shNext.Name & "'!" & SOUR_ADR & "-" & SOUR_ADR
End Sub

Option Explicit
'v4
Sub Заполнить_отправителей()
    Application.StatusBar = "Ждите..."
    Dim shBeru As Worksheet
    Set shBeru = Sheets("Берут")

    Dim shOtda As Worksheet
    Set shOtda = Sheets("Отдают")

    Dim dicOtda As Dictionary
    Set dicOtda = GetDicOtda(shOtda, xGrp:=1, xToo:=5, xQua:=11)
    
    Dim rTarget As Range
    Set rTarget = shBeru.Cells(1, 10)
    rTarget.Resize(shBeru.UsedRange.Rows.Count, shBeru.UsedRange.Columns.Count).Clear
    
    Dim aPered As Variant
    aPered = GetPeredArray(dicOtda:=dicOtda, shOtda:=shOtda, xOtdaTtt:=3, xOtdaTch:=4, xOtdaToo:=5, xOtdaQua:=11, shBeru:=shBeru, xBeruGrp:=1, xBeruToo:=5, xBeruQua:=8, rTarget:=rTarget)
    If IsEmpty(aPered) Then
        Application.StatusBar = False
        Exit Sub
    End If
    
    PrintArray rTarget, aPered
    Application.StatusBar = False
End Sub

Private Sub PrintArray(rTarget As Range, arr As Variant)
    rTarget.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

Private Function GetPeredArray(dicOtda As Dictionary, shOtda As Worksheet, xOtdaTtt As Long, xOtdaTch As Long, xOtdaToo As Long, xOtdaQua As Long, shBeru As Worksheet, xBeruGrp As Long, xBeruToo As Long, xBeruQua As Long, rTarget As Range) As Variant
    Dim aOtdaTt As Variant, aOtdaTo As Variant, aOtdaTc As Variant, aOtdaQu As Variant
    With shOtda
        aOtdaTt = .Cells(1, xOtdaTtt).Resize(.UsedRange.Row + .UsedRange.Rows.Count - 1, 1).Value
        aOtdaTo = .Cells(1, xOtdaTch).Resize(UBound(aOtdaTt, 1), 1).Value
        aOtdaTc = .Cells(1, xOtdaToo).Resize(UBound(aOtdaTt, 1), 1).Value
        aOtdaQu = .Cells(1, xOtdaQua).Resize(UBound(aOtdaTt, 1), 1).Value
    End With
    
    Dim aBeruGr As Variant, aBeruTo As Variant, aBeruQu As Variant
    With shBeru
        aBeruGr = .Cells(1, xBeruGrp).Resize(.UsedRange.Row + .UsedRange.Rows.Count - 1, 1).Value
        aBeruTo = .Cells(1, xBeruToo).Resize(UBound(aBeruGr, 1), 1).Value
        aBeruQu = .Cells(1, xBeruQua).Resize(UBound(aBeruGr, 1), 1).Value
    End With
    
    Dim aPered As Variant
    ReDim aPered(1 To UBound(aBeruGr, 1))
    
    Dim sTO As String, allTO As Variant
    Dim yb As Long, aOtdaY As Variant, yOtda As Variant, yOpt As Long, dd As Double
    For Each allTO In Array(False, True)
        For yb = 1 To UBound(aBeruGr, 1)
            If IsNumeric(aBeruQu(yb, 1)) Then
                If aBeruQu(yb, 1) > 0 Then
                    If allTO Then
                        sTO = "All"
                    Else
                        sTO = aBeruTo(yb, 1)
                    End If
                
                    If dicOtda.Exists(sTO) Then
                        If dicOtda(sTO).Exists(aBeruGr(yb, 1)) Then
                            aOtdaY = dicOtda(sTO)(aBeruGr(yb, 1)).Keys()
                            
                            Do
                                If aBeruQu(yb, 1) <= 0 Then Exit Do
                                
                                yOpt = 0
                                For Each yOtda In aOtdaY
                                    If aOtdaQu(yOtda, 1) > 0 Then
                                        If yOpt = 0 Then
                                            yOpt = yOtda
                                        ElseIf aOtdaQu(yOtda, 1) = aBeruQu(yb, 1) Then
                                            yOpt = yOtda
                                            Exit For
                                        Else
                                            If Abs(aOtdaQu(yOtda, 1) - aBeruQu(yb, 1)) < Abs(aOtdaQu(yOpt, 1) - aBeruQu(yb, 1)) Then
                                                yOpt = yOtda
                                            ElseIf Abs(aOtdaQu(yOtda, 1) - aBeruQu(yb, 1)) = Abs(aOtdaQu(yOpt, 1) - aBeruQu(yb, 1)) Then
                                                If aOtdaQu(yOtda, 1) > aOtdaQu(yOpt, 1) Then
                                                    yOpt = yOtda
                                                End If
                                            End If
                                        End If
                                    End If
                                Next
                                If yOpt = 0 Then Exit Do
                                
                                dd = aBeruQu(yb, 1)
                                If dd > aOtdaQu(yOpt, 1) Then dd = aOtdaQu(yOpt, 1)
                                aBeruQu(yb, 1) = aBeruQu(yb, 1) - dd
                                aOtdaQu(yOpt, 1) = aOtdaQu(yOpt, 1) - dd
                                If IsEmpty(aPered(yb)) Then
                                    ReDim aTmp(1 To 1)
                                Else
                                    aTmp = aPered(yb)
                                    ReDim Preserve aTmp(LBound(aTmp) To UBound(aTmp) + 1)
                                End If
                                aTmp(UBound(aTmp)) = Array(yOpt, dd)
                                aPered(yb) = aTmp
                                DoEvents
                            Loop
                        End If
                    End If
                End If
            End If
        Next
    Next
    
    Dim xPered As Long
    For yb = 1 To UBound(aPered)
        If Not IsEmpty(aPered(yb)) Then
            aTmp = aPered(yb)
            If xPered < UBound(aTmp) Then
                xPered = UBound(aTmp)
            End If
        End If
    Next
    If xPered = 0 Then Exit Function
    
    Const N_COL = 4
    
    Dim bPered As Variant, xp As Long
    ReDim bPered(1 To UBound(aPered), 1 To N_COL * xPered)
    For xp = 1 To xPered
        bPered(2, N_COL * (xp - 1) + 1) = "К перемещению"
        bPered(2, N_COL * (xp - 1) + 2) = "Код ТТ"
        bPered(2, N_COL * (xp - 1) + 3) = "Точка отправитель"
        bPered(2, N_COL * (xp - 1) + 4) = "ТО"
    Next
    
    For yb = 1 To UBound(aPered)
        If Not IsEmpty(aPered(yb)) Then
            aTmp = aPered(yb)
            xPered = 0
            For xp = LBound(aTmp) To UBound(aTmp)
                yOtda = aTmp(xp)(0)
                bPered(yb, xPered + 1) = aTmp(xp)(1)
                bPered(yb, xPered + 2) = aOtdaTt(yOtda, 1)
                bPered(yb, xPered + 3) = aOtdaTo(yOtda, 1)
                bPered(yb, xPered + 4) = aOtdaTc(yOtda, 1)
                rTarget.Columns(xPered + 1).Resize(UBound(aPered)).Interior.Color = RGB(189, 215, 238)
                xPered = xPered + N_COL
            Next
        End If
    Next
    GetPeredArray = bPered
End Function

Private Function GetDicOtda(sh As Worksheet, xGrp As Long, xToo As Long, xQua As Long) As Dictionary
    Dim agr As Variant, ato As Variant, aqu As Variant
    With sh
        agr = .Cells(1, xGrp).Resize(.UsedRange.Row + .UsedRange.Rows.Count - 1, 1).Value
        ato = .Cells(1, xToo).Resize(UBound(agr, 1), 1).Value
        aqu = .Cells(1, xQua).Resize(UBound(agr, 1), 1).Value
    End With
    
    Dim dic As New Dictionary
    Dim yg As Long, vTO As Variant
    For yg = 1 To UBound(agr, 1)
        If Not IsEmpty(agr(yg, 1)) Then
            If IsNumeric(aqu(yg, 1)) Then
                If aqu(yg, 1) > 0 Then
                    For Each vTO In Array("All", ato(yg, 1))
                        If Not dic.Exists(vTO) Then
                            Set dic(vTO) = New Dictionary
                        End If
                        If Not dic(vTO).Exists(agr(yg, 1)) Then
                            Set dic(vTO)(agr(yg, 1)) = New Dictionary
                        End If
                        dic(vTO)(agr(yg, 1))(yg) = Empty
                    Next
                End If
            End If
        End If
    Next
    Set GetDicOtda = dic
End Function

Option Explicit

Sub Заполнить_отправителей()
    Application.StatusBar = "Ждите..."
    Dim shBeru As Worksheet
    Set shBeru = Sheets("Берут")

    Dim shOtda As Worksheet
    Set shOtda = Sheets("Отдают")

    Dim dicOtda As Dictionary
    Set dicOtda = GetDicOtda(shOtda, xGrp:=1, xToo:=5, xQua:=11)
    
    Dim rTarget As Range
    Set rTarget = shBeru.Cells(1, 10)
    rTarget.Resize(shBeru.UsedRange.Rows.Count, shBeru.UsedRange.Columns.Count).Clear
    
    Dim aPered As Variant
    aPered = GetPeredArray(dicOtda:=dicOtda, shOtda:=shOtda, xOtdaTtt:=3, xOtdaTch:=4, xOtdaQua:=11, shBeru:=shBeru, xBeruGrp:=1, xBeruToo:=5, xBeruQua:=8, rTarget:=rTarget)
    If IsEmpty(aPered) Then
        Application.StatusBar = False
        Exit Sub
    End If
    
    PrintArray rTarget, aPered
    Application.StatusBar = False
End Sub

Private Sub PrintArray(rTarget As Range, arr As Variant)
    rTarget.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

Private Function GetPeredArray(dicOtda As Dictionary, shOtda As Worksheet, xOtdaTtt As Long, xOtdaTch As Long, xOtdaQua As Long, shBeru As Worksheet, xBeruGrp As Long, xBeruToo As Long, xBeruQua As Long, rTarget As Range) As Variant
    Dim aOtdaTt As Variant, aOtdaTo As Variant, aOtdaQu As Variant
    With shOtda
        aOtdaTt = .Cells(1, xOtdaTtt).Resize(.UsedRange.Row + .UsedRange.Rows.Count - 1, 1).Value
        aOtdaTo = .Cells(1, xOtdaTch).Resize(UBound(aOtdaTt, 1), 1).Value
        aOtdaQu = .Cells(1, xOtdaQua).Resize(UBound(aOtdaTt, 1), 1).Value
    End With
    
    Dim aBeruGr As Variant, aBeruTo As Variant, aBeruQu As Variant
    With shBeru
        aBeruGr = .Cells(1, xBeruGrp).Resize(.UsedRange.Row + .UsedRange.Rows.Count - 1, 1).Value
        aBeruTo = .Cells(1, xBeruToo).Resize(UBound(aBeruGr, 1), 1).Value
        aBeruQu = .Cells(1, xBeruQua).Resize(UBound(aBeruGr, 1), 1).Value
    End With
    
    Dim aPered As Variant
    ReDim aPered(1 To UBound(aBeruGr, 1))
    
    Dim yb As Long, aOtdaY As Variant, yOtda As Variant, yOpt As Long, dd As Double
    For yb = 1 To UBound(aBeruGr, 1)
        If IsNumeric(aBeruQu(yb, 1)) Then
            If aBeruQu(yb, 1) > 0 Then
                If dicOtda.Exists(aBeruTo(yb, 1)) Then
                    If dicOtda(aBeruTo(yb, 1)).Exists(aBeruGr(yb, 1)) Then
                        aOtdaY = dicOtda(aBeruTo(yb, 1))(aBeruGr(yb, 1)).Keys()
                        
                        Do
                            If aBeruQu(yb, 1) <= 0 Then Exit Do
                            
                            yOpt = 0
                            For Each yOtda In aOtdaY
                                If aOtdaQu(yOtda, 1) > 0 Then
                                    If yOpt = 0 Then
                                        yOpt = yOtda
                                    ElseIf aOtdaQu(yOtda, 1) = aBeruQu(yb, 1) Then
                                        yOpt = yOtda
                                        Exit For
                                    Else
                                        If Abs(aOtdaQu(yOtda, 1) - aBeruQu(yb, 1)) < Abs(aOtdaQu(yOpt, 1) - aBeruQu(yb, 1)) Then
                                            yOpt = yOtda
                                        ElseIf Abs(aOtdaQu(yOtda, 1) - aBeruQu(yb, 1)) = Abs(aOtdaQu(yOpt, 1) - aBeruQu(yb, 1)) Then
                                            If aOtdaQu(yOtda, 1) > aOtdaQu(yOpt, 1) Then
                                                yOpt = yOtda
                                            End If
                                        End If
                                    End If
                                End If
                            Next
                            If yOpt = 0 Then Exit Do
                            
                            dd = aBeruQu(yb, 1)
                            If dd > aOtdaQu(yOpt, 1) Then dd = aOtdaQu(yOpt, 1)
                            aBeruQu(yb, 1) = aBeruQu(yb, 1) - dd
                            aOtdaQu(yOpt, 1) = aOtdaQu(yOpt, 1) - dd
                            If IsEmpty(aPered(yb)) Then
                                ReDim aTmp(1 To 1)
                            Else
                                aTmp = aPered(yb)
                                ReDim Preserve aTmp(LBound(aTmp) To UBound(aTmp) + 1)
                            End If
                            aTmp(UBound(aTmp)) = Array(yOpt, dd)
                            aPered(yb) = aTmp
                            DoEvents
                        Loop
                    End If
                End If
            End If
        End If
    Next
    
    Dim xPered As Long
    For yb = 1 To UBound(aPered)
        If Not IsEmpty(aPered(yb)) Then
            aTmp = aPered(yb)
            If xPered < UBound(aTmp) Then
                xPered = UBound(aTmp)
            End If
        End If
    Next
    If xPered = 0 Then Exit Function
    
    Dim bPered As Variant, xp As Long
    ReDim bPered(1 To UBound(aPered), 1 To 3 * xPered)
    For xp = 1 To xPered
        bPered(2, 3 * (xp - 1) + 1) = "К перемещению"
        bPered(2, 3 * (xp - 1) + 2) = "Код ТТ"
        bPered(2, 3 * (xp - 1) + 3) = "Точка отправитель"
    Next
    
    For yb = 1 To UBound(aPered)
        If Not IsEmpty(aPered(yb)) Then
            aTmp = aPered(yb)
            xPered = 0
            For xp = LBound(aTmp) To UBound(aTmp)
                yOtda = aTmp(xp)(0)
                bPered(yb, xPered + 1) = aTmp(xp)(1)
                bPered(yb, xPered + 2) = aOtdaTt(yOtda, 1)
                bPered(yb, xPered + 3) = aOtdaTo(yOtda, 1)
                rTarget.Columns(xPered + 1).Resize(UBound(aPered)).Interior.Color = RGB(189, 215, 238)
                xPered = xPered + 3
            Next
        End If
    Next
    GetPeredArray = bPered
End Function

Private Function GetDicOtda(sh As Worksheet, xGrp As Long, xToo As Long, xQua As Long) As Dictionary
    Dim agr As Variant, ato As Variant, aqu As Variant
    With sh
        agr = .Cells(1, xGrp).Resize(.UsedRange.Row + .UsedRange.Rows.Count - 1, 1).Value
        ato = .Cells(1, xToo).Resize(UBound(agr, 1), 1).Value
        aqu = .Cells(1, xQua).Resize(UBound(agr, 1), 1).Value
    End With
    
    Dim dic As New Dictionary
    Dim yg As Long
    For yg = 1 To UBound(agr, 1)
        If Not IsEmpty(agr(yg, 1)) Then
            If IsNumeric(aqu(yg, 1)) Then
                If aqu(yg, 1) > 0 Then
                    If Not dic.Exists(ato(yg, 1)) Then
                        Set dic(ato(yg, 1)) = New Dictionary
                    End If
                    If Not dic(ato(yg, 1)).Exists(agr(yg, 1)) Then
                        Set dic(ato(yg, 1))(agr(yg, 1)) = New Dictionary
                    End If
                    dic(ato(yg, 1))(agr(yg, 1))(yg) = Empty
                End If
            End If
        End If
    Next
    Set GetDicOtda = dic
End Function

=СЧЁТЕСЛИМН(B:B;A:A)>0