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

Option Explicit

Sub Размер_шрифта()
    Dim cl As Range
    For Each cl In Intersect(Selection, ActiveSheet.UsedRange).Cells
        ChangeFontSize cl
    Next
End Sub

Sub ChangeFontSize(cl As Range)
    Application.ScreenUpdating = False
    Dim ss As Variant
    ss = cl.Value
    If InStr(ss, vbLf) = 0 Then Exit Sub
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ys As Long
    For ys = 1 To Len(ss)
        With cl.Characters(Start:=ys, Length:=1).Font
            dic(ys) = Array(Mid(ss, ys, 1), .Size, .Color, 1)
        End With
    Next
    For ys = dic.Count To 2 Step -1
        If dic(ys)(0) = Chr(10) Then
            If dic(ys - 1)(0) = Chr(10) Then
                dic.Remove ys
            End If
        End If
    Next
    
    ss = ""
    For ys = 0 To dic.Count - 1
        ss = ss & dic.Items()(ys)(0)
    Next
    cl.Value = ss
    Dim fontSize As Long, sizeFlag As Boolean
    fontSize = dic.Items()(0)(1)
    For ys = 0 To dic.Count - 1
        If dic.Items()(ys)(0) = Chr(10) Then
            sizeFlag = True
        End If
        
        If True Then
            With cl.Characters(Start:=ys + 1, Length:=1).Font
                If sizeFlag Then
                    .Size = fontSize / 2 + 1
                Else
                    .Size = fontSize
                End If
                .Color = dic.Items()(ys)(2)
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Option Explicit

Sub Перенести()
    Dim shSource As Worksheet, shTarget As Worksheet
    Set shSource = ActiveWorkbook.Sheets("Заяка")
    Set shTarget = GetTargetSheet(shSource.Parent, shSource.Range("E3").Value)
    If shTarget Is Nothing Then Exit Sub
    
    shSource.Range("F5:I18").Copy shTarget.Range("G8")
    Application.Goto shTarget.Range("G8")
End Sub

Private Function GetTargetSheet(wb As Workbook, fio As String) As Worksheet
    If fio = "" Then Exit Function
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        If sh.Range("F6").Value = fio Then
            Set GetTargetSheet = sh
            Exit Function
        End If
    Next
End Function

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 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

=И(ИЛИ(И(ЯЧЕЙКА("строка")>=СТРОКА(A17);ЯЧЕЙКА("строка")<=СТРОКА(A22)));ИНДЕКС($W$1:$W$21;ЯЧЕЙКА("строка"))="+")

'v5
Function СУММЕСЛИДРОБЬ(диапазон_суммирования As Range, диапазон_условия As Range, условие As Variant) As String
    Const delimeter = "/"
      
    Dim aSumm As Variant, aCond As Variant
    aSumm = диапазон_суммирования.Value
    aCond = диапазон_условия.Resize(диапазон_суммирования.Rows.Count, диапазон_суммирования.Columns.Count).Value
    
    aSumm = ClearArray(aSumm)
    aCond = ClearArray(aCond)
    
    Dim ya As Long, xa As Long, xb As Long, arr As Variant, brr As Variant
    For ya = 1 To UBound(aSumm, 1)
        For xa = 1 To UBound(aSumm, 2)
            If aCond(ya, xa) = условие Then
                If InStr(aSumm(ya, xa), delimeter) > 0 Then
                    arr = Split(aSumm(ya, xa), delimeter)
                    If IsEmpty(brr) Then
                        ReDim brr(LBound(arr) To UBound(arr))
                    ElseIf UBound(arr) > UBound(brr) Then
                        ReDim Preserve brr(LBound(brr) To UBound(arr))
                    End If
                    For xb = LBound(arr) To UBound(arr)
                        If IsNumeric(arr(xb)) Then
                            brr(xb) = CLng(brr(xb)) + CLng(arr(xb))
                        End If
                    Next
                End If
            End If
        Next
    Next
    If Not IsEmpty(brr) Then
        СУММЕСЛИДРОБЬ = Join(brr, delimeter)
    Else
        СУММЕСЛИДРОБЬ = ""
    End If
End Function
 
Private Function ClearArray(ByVal arr As Variant) As Variant
    Dim ya As Long
    Dim xa As Long
    For ya = LBound(arr, 1) To UBound(arr, 1)
        For xa = LBound(arr, 2) To UBound(arr, 2)
            If IsError(arr(ya, xa)) Then
                arr(ya, xa) = Empty
            End If
        Next
    Next
    ClearArray = arr
End Function

Sub Удалить_замечаний_нет()
    Dim tb As ListObject
    Set tb = Sheets("Основная").ListObjects("Таблица1")
    
    Dim yt As Long, res As Range, obj As Range
    For yt = tb.DataBodyRange.Rows.Count To 1 Step -1
        If tb.ListColumns("Замечание").DataBodyRange.Cells(yt, 1).Value = "Замечаний нет" Then
            Set res = tb.ListColumns("УЭС/РЭС").DataBodyRange.Cells(yt, 1)
            Set obj = tb.ListColumns("Объект").DataBodyRange.Cells(yt, 1)
            If WorksheetFunction.CountIfs(res.Resize(tb.DataBodyRange.Rows.Count), res.Value, obj.Resize(tb.DataBodyRange.Rows.Count), obj.Value) > 1 Then
                tb.ListRows(yt).Delete
            End If
        End If
    Next
End Sub

'v4
Function СУММЕСЛИДРОБЬ(диапазон_суммирования As Range, диапазон_условия As Range, условие As Variant) As String
    Const delimeter = "/"
     
    Dim aSumm As Variant, aCond As Variant
    aSumm = диапазон_суммирования.Value
    aCond = диапазон_условия.Resize(диапазон_суммирования.Rows.Count, диапазон_суммирования.Columns.Count).Value
     
    Dim ya As Long, xa As Long, xb As Long, arr As Variant, brr As Variant
    For ya = 1 To UBound(aSumm, 1)
        For xa = 1 To UBound(aSumm, 2)
            If aCond(ya, xa) = условие Then
                If InStr(aSumm(ya, xa), delimeter) > 0 Then
                    arr = Split(aSumm(ya, xa), delimeter)
                    If IsEmpty(brr) Then
                        ReDim brr(LBound(arr) To UBound(arr))
                    ElseIf UBound(arr) > UBound(brr) Then
                        ReDim Preserve brr(LBound(brr) To UBound(arr))
                    End If
                    For xb = LBound(arr) To UBound(arr)
                        If IsNumeric(arr(xb)) Then
                            brr(xb) = CLng(brr(xb)) + CLng(arr(xb))
                        End If
                    Next
                End If
            End If
        Next
    Next
    СУММЕСЛИДРОБЬ = Join(brr, delimeter)
End Function

'v3
Function СУММЕСЛИДРОБЬ(диапазон_суммирования As Range, диапазон_условия As Range, условие As Variant) As String
    Const delimeter = "/"
    
    Dim aSumm As Variant, aCond As Variant
    aSumm = диапазон_суммирования.Value
    aCond = диапазон_условия.Resize(диапазон_суммирования.Rows.Count, диапазон_суммирования.Columns.Count).Value
    
    Dim ya As Long, xa As Long, xb As Long, arr As Variant, brr As Variant
    For ya = 1 To UBound(aSumm, 1)
        For xa = 1 To UBound(aSumm, 2)
            If aCond(ya, xa) = условие Then
                arr = Split(aSumm(ya, xa), delimeter)
                If IsEmpty(brr) Then
                    ReDim brr(LBound(arr) To UBound(arr))
                ElseIf UBound(arr) > UBound(brr) Then
                    ReDim Preserve brr(LBound(brr) To UBound(arr))
                End If
                For xb = LBound(arr) To UBound(arr)
                    If IsNumeric(arr(xb)) Then
                        brr(xb) = CLng(brr(xb)) + CLng(arr(xb))
                    End If
                Next
            End If
        Next
    Next
    СУММЕСЛИДРОБЬ = Join(brr, delimeter)
End Function

Option Explicit
'v2
Function СУММЕСЛИДРОБЬ(диапазон_суммирования As Range, диапазон_условия As Range, условие As Variant) As String
    Const delimeter = "/"
    
    Dim aSumm As Variant, aCond As Variant
    aSumm = диапазон_суммирования.Value
    aCond = диапазон_условия.Resize(диапазон_суммирования.Rows.Count).Value
    
    Dim ya As Long, xb As Long, arr As Variant, brr As Variant
    For ya = 1 To UBound(aSumm, 1)
        If aCond(ya, 1) = условие Then
            arr = Split(aSumm(ya, 1), delimeter)
            If IsEmpty(brr) Then
                ReDim brr(LBound(arr) To UBound(arr))
            ElseIf UBound(arr) > UBound(brr) Then
                ReDim Preserve brr(LBound(brr) To UBound(arr))
            End If
            For xb = LBound(arr) To UBound(arr)
                If IsNumeric(arr(xb)) Then
                    brr(xb) = CLng(brr(xb)) + CLng(arr(xb))
                End If
            Next
        End If
    Next
    СУММЕСЛИДРОБЬ = Join(brr, delimeter)
End Function

=ЕСЛИОШИБКА(ЗНАЧЕН(СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ($D4;"/";ПОВТОР(" ";10));10*(СТОЛБЕЦ(A:A)-1)+1;10)));0)

=СУММЕСЛИМН($O$4:$O$24;$A$4:$A$24;$A29)&"/"&СУММЕСЛИМН($P$4:$P$24;$A$4:$A$24;$A29)