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

=ЕСЛИ(E6="я";СЛУЧМЕЖДУ(ОКРУГЛВНИЗ(ЕСЛИОШИБКА(($B$2-СУММ($C7:D7))/СЧЁТЕСЛИМН(E6:$AI6;"я");0);0);ОКРУГЛВВЕРХ(ЕСЛИОШИБКА(($B$2-СУММ($C7:D7))/СЧЁТЕСЛИМН(E6:$AI6;"я");0);0));"")

=ОКРУГЛ(ОСТАТ(ABS(E3)*100;10);0)

=ЕСЛИ(E6=1;СЛУЧМЕЖДУ(ОКРУГЛВНИЗ(ЕСЛИОШИБКА(($B$2-СУММ($C7:D7))/СУММ(E6:$AI6);0);0);ОКРУГЛВВЕРХ(ЕСЛИОШИБКА(($B$2-СУММ($C7:D7))/СУММ(E6:$AI6);0);0));"")

=ЦЕЛОЕ(ОСТАТ(ABS(E2)*100;10))

=ЦЕЛОЕ(ОСТАТ(ABS(E2)*10;10))

=ЗНАЧЕН(ПСТР(ТЕКСТ(ОСТАТ(ABS(E2);1);",00");2;1))

=СУММПРОИЗВ(ПРОМЕЖУТОЧНЫЕ.ИТОГИ(3;СМЕЩ(Лист3!$B$8;СТРОКА(Лист3!$B$8:$B$32)-СТРОКА(Лист3!$B$8);0))*(Лист3!$B$8:$B$32=Лист3!H2))

=СУММПРОИЗВ(ПРОМЕЖУТОЧНЫЕ.ИТОГИ(3;СМЕЩ(Лист3!$B$1;СТРОКА(Лист3!$B$26:$B$50)-1;0))*(Лист3!$B$26:$B$50=Лист3!H2))

Option Explicit

Sub Перенести_отфильтрованные()
    Dim rTarget As Range
    Set rTarget = Sheets("Лист2").Range("D8")
    
    Dim arr As Variant
    arr = GetArr(Sheets("Лист3").Range("A2"))
    rTarget.Resize(rTarget.Parent.UsedRange.Rows.Count, UBound(arr, 2)).ClearContents
    rTarget.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

Private Function GetArr(rSource As Range) As Variant
    Dim aSource As Variant, aTarget As Variant
    aSource = rSource.Resize(rSource.Parent.UsedRange.Rows.Count).Value
    ReDim aTarget(1 To UBound(aSource, 1), 1 To 2)
    Dim ys As Long, yt As Long
    For ys = 1 To UBound(aSource, 1)
        If Not IsEmpty(aSource(ys, 1)) Then
            If Not rSource.Cells(ys, 1).EntireRow.Hidden Then
                yt = yt + 1
                aTarget(yt, 1) = yt
                aTarget(yt, 2) = aSource(ys, 1)
            End If
        End If
    Next
    GetArr = aTarget
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If IsError(Target.Value) Then Exit Sub
    If IsEmpty(Target.Value) Then Exit Sub
      
    Dim tb As ListObject
    On Error Resume Next
    Set tb = Target.ListObject
    On Error GoTo 0
    If tb Is Nothing Then
        If WorksheetFunction.CountIfs(Target.EntireColumn.Resize(Target.Row), Target.Value) > 1 Then
            SelectTargetCell Target, Cells(3, Target.Column + 1)
        End If
    Else
        If WorksheetFunction.CountIfs(Intersect(Target.EntireColumn.Resize(Target.Row), tb.DataBodyRange), Target.Value) > 1 Then
            SelectTargetCell Target, Intersect(Target.Cells(1, 2).EntireColumn, tb.DataBodyRange.Rows(1))
        End If
    End If
End Sub
 
Private Sub SelectTargetCell(sourceRange As Range, targetRange As Range)
    targetRange.Select
    targetRange.Value = sourceRange.Value
    sourceRange.Value = Empty
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If IsError(Target.Value) Then Exit Sub
    If IsEmpty(Target.Value) Then Exit Sub
     
    Dim tb As ListObject
    On Error Resume Next
    Set tb = Target.ListObject
    On Error GoTo 0
    If tb Is Nothing Then
        If WorksheetFunction.CountIfs(Target.EntireColumn.Resize(Target.Row), Target.Value) > 1 Then
            SelectTargetCell Target, Cells(3, Target.Column + 1)
        End If
    Else
        If WorksheetFunction.CountIfs(Intersect(Target.EntireColumn.Resize(Target.Row), tb.DataBodyRange), Target.Value) > 1 Then
            SelectTargetCell Target, Intersect(Target.Cells(1, 2).EntireColumn, tb.DataBodyRange.Rows(1))
        End If
    End If
End Sub

Private Sub SelectTargetCell(sourceRange As Range, targetRange As Range)
    targetRange.Select
    targetRange.Value = sourceRange.Value
End Sub

    Dim xLine As Long
    xLine = InStr(Target.Value, Chr(10)) + 1
    
    With Target.Characters(1, xLine - 1).Font
           .Size = 15
    End With
    With Target.Characters(xLine, Len(Target.Value) - xLine + 1).Font
        .Size = 11
    End With

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If IsError(Target.Value) Then Exit Sub
    If IsEmpty(Target.Value) Then Exit Sub
    
    Dim tb As ListObject
    On Error Resume Next
    Set tb = Target.ListObject
    On Error GoTo 0
    If tb Is Nothing Then
        If WorksheetFunction.CountIfs(Target.EntireColumn.Resize(Target.Row), Target.Value) > 1 Then
            Cells(3, Target.Column + 1).Select
        End If
    Else
        If WorksheetFunction.CountIfs(Intersect(Target.EntireColumn.Resize(Target.Row), tb.DataBodyRange), Target.Value) > 1 Then
            Intersect(Target.Cells(1, 2).EntireColumn, tb.DataBodyRange.Rows(1)).Select
        End If
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If IsError(Target.Value) Then Exit Sub
    If IsEmpty(Target.Value) Then Exit Sub
    
    If WorksheetFunction.CountIfs(Target.EntireColumn.Resize(Target.Row), Target.Value) > 1 Then
        Cells(3, Target.Column + 1).Select
    End If
End Sub