С4         =ЕСЛИОШИБКА(ИНДЕКС($A$1:$A$15;ПОИСКПОЗ(СТРОКА(C1);D:D;0));"")
D4         =D3+(СЧЁТЕСЛИМН($A$1:A4;A4)=1)

Sub test()
    Dim cl As Range
    For Each cl In Range("F14:F24")
        cl.Cells(1, 2).Value = GetCellFormula(cl)
    Next
End Sub
Function GetCellFormula(cl As Range) As String
    Dim ss As String
    ss = cl.FormulaLocal
    ss = Replace(ss, "$", "")
    
    Dim dd As Double
    Dim rDP As Range
    On Error Resume Next
    Set rDP = cl.DirectPrecedents
    On Error GoTo 0
    If Not rDP Is Nothing Then
        Dim dp As Range
        For Each dp In rDP
            dd = dp.Value
            ss = Replace(ss, dp.Address(0, 0, xlA1), dd)
        Next
    End If
    GetCellFormula = "'" & ss
End Function

Cells(i, FactValue).Formula = "=(" & Replace(k, ",", ".") & "/1.2)/курс"

Sub test()
    mySumm Range("B2:B30"), Range("C2:C30"), Range("D2"), "Коврик"
End Sub

Sub mySumm(rNames As Range, rValue As Range, rTarget As Range, lookString As String)
    Dim aNam As Variant
    Dim aVal As Variant
    aNam = rNames
    aVal = rValue.Cells(1, 1).Resize(UBound(aNam, 1))
    
    Dim dd As Double
    Dim yy As Long
    For yy = 1 To UBound(aNam)
        If aNam(yy, 1) Like "*" & lookString & "*" Then
            dd = dd + aVal(yy, 1)
        End If
    Next
    
    rTarget.Value = dd
End Sub

=СУММЕСЛИМН(C2:C30;B2:B30;"=Коврик*")

Sub четырнадцать3()
    With Workbooks("исполнительная.xlsm")
        Dim vv As Variant
        Dim q, w As Integer
        Dim arr As Variant
        ReDim arr(1 To 1, 1 To 9)
        arr(1, 4) = "Сварка"
        arr(1, 6) = "200"
        arr(1, 7) = "0.04"
        arr(1, 9) = "годно"
          
        Dim drr As Variant
          
        w = 0
        For Each vv In Array(5, 6, 7)
            
            With .Sheets("Даные")
                q = .Cells(.Rows.Count, vv).End(xlUp).Row
                drr = .Range(.Cells(1, vv), .Cells(q, vv))
            End With
            If UBound(drr, 1) > 6 Then
                If drr(6, 1) <> " " Then
                    q = 1
                    Do While Not IsEmpty(drr(6 + q, 1))
                        w = w + 1
                        arr(1, 1) = (0 + w) & "."
                        arr(1, 2) = "Заземляющий электрод в районе опоры ВЛ-0,4 кВ " & drr(6 + q, 1)
                        arr(1, 3) = "Стальной выпуск опоры " & drr(6 + q, 1)
                        
                        With .Sheets("Лист14")
                            .Cells(21 + w, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
                            .Range(.Cells(21 + w, 4), .Cells(21 + w, 5)).Merge
                            .Range(.Cells(21 + w, 7), .Cells(21 + w, 8)).Merge
                            .Range(.Cells(21 + w, 9), .Cells(21 + w, 10)).Merge
                            .Range(.Cells(21 + w, 4), .Cells(21 + w, 5)).Borders.LineStyle = xlContinuous
                            .Range(.Cells(21 + w, 7), .Cells(21 + w, 8)).Borders.LineStyle = xlContinuous
                            .Range(.Cells(21 + w, 9), .Cells(21 + w, 10)).Borders.LineStyle = xlContinuous
                        End With
                        q = q + 1
                        If 6 + q > UBound(drr, 1) Then Exit Do
                    Loop
                End If
            End If
        Next
    End With
End Sub

Sub четырнадцать2()
Dim vv As Variant
Dim q, w As Integer
  
w = 0
For Each vv In Array(5, 6, 7)
    If Workbooks("исполнительная.xlsm").Sheets("Даные").Cells(6 + q, vv).Value <> " " Then
        q = 1
        Do While Not IsEmpty(Workbooks("исполнительная.xlsm").Sheets("Даные").Cells(6 + q, vv).Value)
            w = w + 1
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 1).Value = (0 + w) & "."
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 2).Value = "Заземляющий электрод в районе опоры ВЛ-0,4 кВ " & Workbooks("исполнительная.xlsm").Sheets("Даные").Cells(6 + q, vv).Value
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 3).Value = "Стальной выпуск опоры " & Workbooks("исполнительная.xlsm").Sheets("Даные").Cells(6 + q, vv).Value
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 4).Value = "Сварка"
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 6).Value = "200"
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 7).Value = "0.04"
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Cells(21 + w, 9).Value = "годно"
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Range(Cells(21 + w, 4), Cells(21 + w, 5)).Merge
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Range(Cells(21 + w, 7), Cells(21 + w, 8)).Merge
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Range(Cells(21 + w, 9), Cells(21 + w, 10)).Merge
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Range(Cells(21 + w, 4), Cells(21 + w, 5)).Borders.LineStyle = xlContinuous
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Range(Cells(21 + w, 7), Cells(21 + w, 8)).Borders.LineStyle = xlContinuous
            Workbooks("исполнительная.xlsm").Sheets("Лист14").Range(Cells(21 + w, 9), Cells(21 + w, 10)).Borders.LineStyle = xlContinuous
            q = q + 1
        Loop
    End If
Next
  
End Sub

Sub Собрать()
    Const RESULT_SHEET_NAME = "ОТЧЕТ"

    Dim wb As Workbook
    Set wb = ActiveWorkbook

    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        If sh.Name <> RESULT_SHEET_NAME Then
            CollectFromSheet sh, dic, 6, [B1].Column, [CY1].Column
        End If
    Next
    Dim arr As Variant
    arr = DicToArr(dic)
    PrintResult wb.Sheets(RESULT_SHEET_NAME).Range("B6"), arr
End Sub

Private Function DicToArr(dic As Object) As Variant
    Dim arr As Variant
    If dic.Count = 0 Then
        ReDim arr(1 To 1, 1 To 2)
    Else
        ReDim arr(1 To dic.Count, 1 To 2)
        Dim brr As Variant
        brr = Array(dic.Keys(), dic.Items())
        Dim yy As Long
        Dim xx As Long
        For yy = 1 To UBound(arr, 1)
            For xx = 1 To UBound(arr, 2)
                arr(yy, xx) = brr(xx - 1)(yy - 1)
            Next
        Next
    End If
    DicToArr = arr
End Function

Private Sub PrintResult(rn As Range, arr As Variant)
    Application.EnableEvents = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    rn.Resize(rn.Parent.UsedRange.Rows.Count, UBound(arr, 2)).ClearContents
    rn.Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
    Application.Calculation = Application_Calculation
    Application.EnableEvents = True
End Sub

Private Sub CollectFromSheet(sh As Worksheet, dic As Object, y1 As Long, xID As Long, xVa As Long)
    Dim arr As Variant
    Dim yy As Long
    Dim dd As Double
    Dim ss As String
    With sh
        yy = .Cells(.Rows.Count, xID).End(xlUp).Row
        If yy >= y1 Then
            Dim aID As Variant
            Dim aVa As Variant
            aID = .Cells(1, xID).Resize(yy)
            aVa = .Cells(1, xVa).Resize(yy)
            For yy = y1 To UBound(aID, 1)
                ss = ""
                dd = 0
                On Error Resume Next
                ss = aID(yy, 1)
                dd = aVa(yy, 1)
                On Error GoTo 0
                If dd <> 0 Then
                    If ss <> "" Then
                        dic.Item(ss) = dic.Item(ss) + dd
                    End If
                End If
            Next
        End If
    End With
End Sub

Sub четырнадцать()
Dim vv As Variant
Dim q, w As Integer
 
w = 0
For Each vv In Array(5, 6, 7)
    If Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, 6).Value <> " " Then
        q = 1
        Do While Not IsEmpty(Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, vv).Value)
            w = w + 1
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 1).Value = (0 + q) & "."
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 2).Value = "Заземляющий электрод в районе опоры ВЛ-0,4 кВ " & Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, vv).Value
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 3).Value = "Стальной выпуск опоры " & Workbooks("исполнительная").Sheets("Даные").Cells(6 + q, vv).Value
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 4).Value = "Сварка"
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 6).Value = "200"
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 7).Value = "0.04"
            Workbooks("исполнительная").Sheets("Лист14").Cells(21 + q, 9).Value = "годно"
            Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 4), Cells(21 + q, 5)).Merge
            Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 7), Cells(21 + q, 8)).Merge
            Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 9), Cells(21 + q, 10)).Merge
            Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 4), Cells(21 + q, 5)).Borders.LineStyle = xlContinuous
            Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 7), Cells(21 + q, 8)).Borders.LineStyle = xlContinuous
            Workbooks("исполнительная").Sheets("Лист14").Range(Cells(21 + q, 9), Cells(21 + q, 10)).Borders.LineStyle = xlContinuous
            q = q + 1
        Loop
    End If
Next
 
End Sub

=СМЕЩ(Лист2!$J$1;1;0;Лист2!$J$1;1)

H2        =H1+(Номера<>0)
I2        =Номера
J2        =ВПР(СТРОКА(J1);H:I;2;0)

=МАКС(H:H)

D1     ЦЕНА2
D2     =МАКС((A2=[КОД])*(C2=[ДАТА ИЗМЕНЕНИЯ])*[ЦЕНА])    (формула массива)

ЦЕНЫ!B2       =ИНДЕКС(Таблица1[[#Все];[ЦЕНА2]];МАКС((Таблица1[ДАТА ИЗМЕНЕНИЯ]=МАКС((A2=Таблица1[КОД])*Таблица1[ДАТА ИЗМЕНЕНИЯ]))*СТРОКА(Таблица1[ДАТА ИЗМЕНЕНИЯ])))

=ИНДЕКС(Таблица1[[#Все];[ЦЕНА]];МАКС((Таблица1[ДАТА ИЗМЕНЕНИЯ]=МАКС((A2=Таблица1[КОД])*Таблица1[ДАТА ИЗМЕНЕНИЯ]))*СТРОКА(Таблица1[ДАТА ИЗМЕНЕНИЯ])))

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("B1:B5")) Is Nothing Then
            If Target <> Empty Then
                Dim lr As Long, cell As Range, sh As Worksheet
                
                Dim ValidFormula As String
                'ValidFormula = "=Номера"
                Set sh = Worksheets("Лист2")
                ValidFormula = GetValidFormula(sh, [A1].Value)
                Set cell = sh.Cells.Find(Target)
                Application.EnableEvents = False
                cell.Delete Shift:=xlUp
                Dim xtb2 As Long
                xtb2 = sh.ListObjects("Таблица2").Range.Column
                If sh.Cells(2, xtb2) = "" Then
                    sh.Cells(2, xtb2) = Target
                Else
                    lr = sh.Cells(Rows.Count, xtb2).End(xlUp).Row - 1
                    sh.Cells(lr, xtb2).ListObject.ListRows.Add AlwaysInsert:=True
                    sh.Cells(lr + 1, xtb2).Value = Target
                End If
                Application.EnableEvents = True
                With Range("B1:B5").Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=ValidFormula
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                End With
            End If
        End If
 End If
End Sub

Function GetValidFormula(sh As Worksheet, colName As String) As String
    Dim arr As Variant
    On Error Resume Next
    arr = sh.ListObjects("Таблица1").ListColumns(colName).DataBodyRange.Resize(, 2)
    On Error GoTo 0
    If Not IsEmpty(arr) Then
        Dim brr As Variant
        Dim yy As Long
        Dim uu As Long
        Dim ii As Long
        For ii = 0 To 1
            uu = 0
            For yy = 1 To UBound(arr, 1)
                If Not IsEmpty(arr(yy, 1)) Then
                    uu = uu + 1
                    If ii Then
                        brr(uu) = arr(yy, 1)
                    End If
                End If
            Next
            If uu Then
                If ii Then
                    GetValidFormula = Join(brr, ",")
                Else
                    ReDim brr(1 To uu)
                End If
            End If
        Next
    End If
End Function

Option Explicit

Const findWhat = "Опасность психических нагрузок, стрессов (при аварийной ситуации)"
Const s2 = "С8 (Ч4 x Т2)"

Sub Заменить()
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    FindInSheet ActiveSheet
    
    Application.Calculation = Application_Calculation
End Sub

Sub FindInSheet(sh As Worksheet)
    With sh.UsedRange
        Dim FoundCell As Range
        Dim LastCell As Range
        Dim FirstAddr As String
        Set LastCell = .Cells(.Rows.Count, .Columns.Count)
        Set FoundCell = .Find(what:=findWhat, after:=LastCell)
         
        If Not FoundCell Is Nothing Then
            FirstAddr = FoundCell.Address
        End If
        Do Until FoundCell Is Nothing
            FoundCellJob FoundCell
            Set FoundCell = .FindNext(after:=FoundCell)
            If FoundCell.Address = FirstAddr Then
                Exit Do
            End If
        Loop
    End With
End Sub
 
Sub FoundCellJob(cl As Range)
    cl.Cells(1, 7).Value = s2
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("B1:B5")) Is Nothing Then
            If Target <> Empty Then
                Dim lr As Long, cell As Range, sh As Worksheet
                Dim ValidFormula As String
                ValidFormula = "=Номера"
                Set sh = Worksheets("Лист2")
                Set cell = sh.Cells.Find(Target)
                Application.EnableEvents = False
                cell.Delete Shift:=xlUp
                Dim xtb2 As Long
                xtb2 = sh.ListObjects("Таблица2").Range.Column
                If sh.Cells(2, xtb2) = "" Then
                    sh.Cells(2, xtb2) = Target
                Else
                    lr = sh.Cells(Rows.Count, xtb2).End(xlUp).Row - 1
                    sh.Cells(lr, xtb2).ListObject.ListRows.Add AlwaysInsert:=True
                    sh.Cells(lr + 1, xtb2).Value = Target
                End If
                Application.EnableEvents = True
                With Range("B1:B5").Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=ValidFormula
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                End With
            End If
        End If
 End If
End Sub

Option Explicit

Const findWhat = "x"

Sub HideRows()
    FindInWb ActiveWorkbook
End Sub

Sub ShowRows()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        sh.UsedRange.EntireRow.Hidden = False
    Next
End Sub

Sub FindInWb(wb As Workbook)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        FindInSheet sh
    Next
End Sub

Sub FindInSheet(sh As Worksheet)
    With sh.UsedRange
        Dim FoundCell As Range
        Dim LastCell As Range
        Dim FirstAddr As String
        Set LastCell = .Cells(.Rows.Count, .Columns.Count)
        Set FoundCell = .Find(what:=findWhat, after:=LastCell)
        
        If Not FoundCell Is Nothing Then
            FirstAddr = FoundCell.Address
        End If
        Do Until FoundCell Is Nothing
            FoundCellJob FoundCell
            Set FoundCell = .FindNext(after:=FoundCell)
            If FoundCell.Address = FirstAddr Then
                Exit Do
            End If
        Loop
    End With
End Sub

Sub FoundCellJob(cl As Range)
    cl.EntireRow.Hidden = True
End Sub

Sub CopyListObjectsColumn()
    Dim tb1 As ListObject
    Set tb1 = Workbooks("Реестр Претензионного отдела.xlsm").Sheets("РЕЕСТР").ListObjects("Таблица4")
      
    Dim tb2 As ListObject
    Set tb2 = Workbooks("Портянка.xlsm").Sheets("Лист1").ListObjects("Таблица1")
      
    Dim arr As Variant
      
    Dim colName As Variant
    On Error Resume Next
    For Each colName In Array("№п/п", "ЖК", "Корпус", "Тип помещения", "Номер помещения", "Отделка", "Этап получения замечания", "Дата обращения", "Общий статус обращения", "Замечание клиента", "Статус замечания", "Исполнитель", "Время устранения", "Статус ТМЦ", "Статус материалов", "Комментарии", "Столбец1")
        arr = tb1.ListColumns(colName).DataBodyRange
        tb2.ListColumns(colName).DataBodyRange.Resize(tb1.ListColumns(colName).DataBodyRange.Rows.Count, 1).Value = arr
        If Err Then
            MsgBox "Проверьте столбец " & colName, vbCritical
            Exit For
        End If
    Next
    On Error GoTo 0
End Sub

C2      =C1+(A2<>A1)*(СЧЁТЕСЛИМН(A:A;A1)+1)
D2      =ЕСЛИ(C2=C1;D1+1;C2)
E2      =ЕСЛИОШИБКА(ЕСЛИОШИБКА(ИНДЕКС($B$1:$B$14;ПОИСКПОЗ(СТРОКА();$D$1:$D$14;0));ИНДЕКС($A$1:$A$14;ПОИСКПОЗ(СТРОКА()+1;$D$1:$D$14;0)));"")

=ДВССЫЛ("Таблица1["&Лист1!$A$1&"]")

 .Left = ActiveCell.Left + ActiveCell.Width + 10

 Workbooks("Реестр Претензионного отдела").Sheets("РЕЕСТР").ListObjects("Таблица4")

=СУММ(ЕСЛИОШИБКА((МЕСЯЦ(B5)-МЕСЯЦ($B$5:$Z$5)+12*(ГОД(B5)-ГОД($B$5:$Z$5))=$B$1:$Z$1);0)*($B$6:$Z$6))