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

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row < 4 Then Exit Sub
If Cells(1, Target.Column).Text = "T" Then
    InputStr = InputBox("Новый комментарий от " + Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + " :", "Комментарий")
    If Len(InputStr) = 0 Then Exit Sub
    Do
        If InStr(Target.Value, String(2, Chr(10))) = 0 Then Exit Do
        Target.Value = Replace(Target.Value, String(2, Chr(10)), Chr(10))
        DoEvents
     Loop
    If Len(Target.Value) = 0 Then
        Target.Value = Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + ": " + InputStr
    Else
        Target.Value = Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + ": " + InputStr + Chr(10) + Chr(13) + Target.Text
    End If
    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

If Cells(1, Target.Column) = "D" Then
InputStr = InputBox("Введите новую дату")
intA = Len(Target.Text)

 If Len(InputStr) = 0 Then Exit Sub
    Target.Value = InputStr + Chr(10) + Target.Text
    Do
        If InStr(Target.Value, String(2, Chr(10))) = 0 Then Exit Do
        Target.Value = Replace(Target.Value, String(2, Chr(10)), Chr(10))
        DoEvents
    Loop
    With Target.Characters(Len(InputStr) + 2, Len(Target.Value) - Len(InputStr)).Font
        .Name = "Calibri"
        .Size = 7
        .Color = -16777216
    End With
    
End If
End Sub
Function GetFullUserName()
    Dim objADSysInfo As Object, objUser As Object
    Set objADSysInfo = CreateObject("ADSystemInfo")
    Set objUser = GetObject("LDAP://" & objADSysInfo.UserName)
    GetFullUserName = objUser.DisplayName
End Function

Function GetCutUserName()
UN = GetFullUserName()
GetCutUserName = Left(UN, 1) + Mid(UN, InStr(UN, " ") + 1, 1) + Mid(UN, InStr(InStr(UN, " ") + 1, UN, " ") + 1, 1)
End Function

=И(ИЛИ(И(ЯЧЕЙКА("строка")>=17;ЯЧЕЙКА("строка")<=22));ИНДЕКС($W$1:$W$21;ЯЧЕЙКА("строка"))<>"")

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rInput As Range
    On Error Resume Next
    Set rInput = Intersect(Target, Range("H10:L21"))
    On Error GoTo 0
    If rInput Is Nothing Then Exit Sub
    
    Dim ci As Range
    For Each ci In rInput.Cells
        ChangeCell ci
    Next
End Sub

Private Sub ChangeCell(inputCell As Range)
    Dim rg As Range, rw As Range
    Set rw = Range("W" & inputCell.Row)
    Set rg = Range("G" & inputCell.Row).MergeArea.Cells(1, 1)
    
    Dim targetRow As Long
    If Not IsEmpty(rw.Value) Then                          ' <----------------------------- ТУТ.
        targetRow = WorksheetFunction.Match(rg.Value & "+", Range("R1:R8"), 0)
    Else
        targetRow = WorksheetFunction.Match(rg.Value, Range("R1:R8"), 0)
    End If
    
    Range("N3:R8").Interior.Color = RGB(255, 255, 153)
    Range("N1:R8").Rows(targetRow).Interior.Color = RGB(255, 128, 128)
End Sub