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

With Target.Characters(1, 17).Font
       .Name = "Calibri"
       .FontStyle = "обычный"
       .Size = 15           'Если уберёте эту строку, то выполнится часть, обозначенная как "ОСТАВИТЬ" - не изменится размер первой строки.
       .Color = -65536
       End With
   With Target.Characters(17, Len(Target.Value) - 16).Font
       .Name = "Calibri"
       .FontStyle = "обычный"
       .Size = 11           'Если отредактируете эту строку, то выполнится часть, обозначенная как "УМЕНЬШИТЬ" - изменится размер последующих строк.
       .Color = -16777216
   End With
End If

=ИНДЕКС('Список изделий'!F:F;ПОИСКПОЗ($C$2;'Список изделий'!$C:$C;0)-1+СТРОКА(A1))

Sub myCopy()
    Dim shSource As Worksheet
    Set shSource = Sheets("4-й акт")
    
    Dim shTarget As Worksheet
    shSource.Copy
    Set shTarget = ActiveSheet
    
    shTarget.UsedRange.Value = shSource.UsedRange.Value
    
    With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
        .DeleteLines 1, .CountOfLines
    End With
End Sub