=СЧЁТЕСЛИМН(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