Sub Copy_sheet()
    Dim sh As Worksheet
    Set sh = Worksheets("Шаблон")
    
    Dim sPath As String, sName As String
    sPath = sh.Parent.Path & "\"
    
    sh.Copy
    Set sh = ActiveSheet
    sName = sh.Range("L7").Value
    sh.UsedRange.Value = sh.UsedRange.Value
    On Error Resume Next
    Workbooks(sName & ".xlsx").Close False
    Kill sPath & sName & ".xlsx"
    Kill sPath & sName & ".pdf"
    On Error GoTo 0
    sh.Parent.SaveAs sPath & sName & ".xlsx"
    sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath & sName & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub

Sub Копировать_лист()
    SheetCopy ActiveSheet
End Sub
 
Sub SheetCopy(shSource As Worksheet)
    Dim sName As String
    sName = shSource.Name
    If sName Like "*.*" Then
        If IsDate(sName & "." & Year(Date)) Then
            Dim dt As Date
            dt = CDate(sName & "." & Year(Date))
            dt = dt + 1
            sName = Format(dt, "DD.MM")
             
            Dim shTarget As Worksheet
            On Error Resume Next
            Set shTarget = shSource.Parent.Worksheets(sName)
            On Error GoTo 0
            If Not shTarget Is Nothing Then
                If MsgBox("Лист " & sName & " существует. Удалить?", vbQuestion + vbYesNo, "Копирование листа") = vbYes Then
                    Application.DisplayAlerts = False
                    shTarget.Delete
                    Application.DisplayAlerts = True
                    Set shTarget = Nothing
                End If
            End If
            If shTarget Is Nothing Then
                shSource.Copy After:=shSource
                Set shTarget = shSource.Parent.Worksheets(shSource.Index + 1)
                shTarget.Name = sName
                shTarget.Buttons.Delete
            End If
        End If
    End If
End Sub

Sub Копировать_лист()
    SheetCopy ActiveSheet
End Sub

Sub SheetCopy(sh As Worksheet)
    Dim sName As String
    sName = sh.Name
    If sName Like "*.*" Then
        If IsDate(sName & ".2025") Then
            Dim dt As Date
            dt = CDate(sName & ".2025")
            dt = dt + 1
            sName = Format(dt, "DD.MM")
            
            Dim sheetExists As Boolean
            On Error Resume Next
            With sh.Parent.Worksheets(sName): End With
            If Err = 0 Then sheetExists = True
            On Error GoTo 0
            If Not sheetExists Then
                sh.Copy After:=sh
                sh.Parent.Worksheets(sh.Index + 1).Name = sName
            Else
                MsgBox "О чём ты думал!", vbCritical, "Копирование листа"
            End If
        End If
    End If
End Sub

Option Explicit
Private Const sFOLDER = "C:\tmp\"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rp As Range
    On Error Resume Next
    Set rp = Columns("I:I")
    Set rp = Intersect(rp, Target)
    Set rp = Intersect(rp, rp.Parent.UsedRange)
    On Error GoTo 0
    If rp Is Nothing Then Exit Sub
    
    Dim cp As Range, cl As Range
    For Each cp In rp.Cells
        Set cl = cp.EntireRow.Columns("J:J")
        cl.Hyperlinks.Delete
        If cp.Value <> "" Then
            AddLink cl, cp.Value
        Else
            cl.Hyperlinks.Delete
        End If
    Next
End Sub

Private Sub AddLink(cTarg As Range, sMask As String)
    Dim sName As String
    sName = Dir(sFOLDER & "*" & sMask & "*.pdf")
    Do
        If sName = "" Then Exit Do
        cTarg.Hyperlinks.Delete
        cTarg.Parent.Hyperlinks.Add Anchor:=cTarg, Address:=sFOLDER & sName, TextToDisplay:=sName
        Set cTarg = cTarg.Cells(1, 2)
        sName = Dir
        DoEvents
    Loop
End Sub

=ГИПЕРССЫЛКА("C:\tmp\"&I2&".txt")

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C2").Resize(ActiveSheet.UsedRange.Rows.Count)) Is Nothing Then
        Dim cl As Range, ce As Range
        For Each cl In Intersect(Target, Range("C2").Resize(ActiveSheet.UsedRange.Rows.Count)).Cells
            Set ce = cl.EntireRow.Range("E1")
            Application.EnableEvents = False
            If IsEmpty(cl.Value) Then
                ce.ClearContents
            Else
                ce.FormulaR1C1 = "=IF(IFERROR(VLOOKUP(RC[-2],Ïåðå÷åíü!R2C1:R150C3,3,0),"""")=0,"""",IFERROR(VLOOKUP(RC[-2],Ïåðå÷åíü!R2C1:R150C3,3,0),""""))"
                ce.Value = ce.Value
                If ce.Value = "" Then ce.ClearContents
            End If
            Application.EnableEvents = True
        Next
    End If
End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("C2").Resize(ActiveSheet.UsedRange.Rows.Count - 1)) Is Nothing Then Exit Sub
    
    Dim shP As Worksheet
    Set shP = Sheets("Поставка")
    
    Dim rp As Range, rf As Range, prr As Variant, frr As Variant, yp As Long, flag As Boolean
    Set rp = shP.Cells(1, 3).Resize(shP.UsedRange.Row + shP.UsedRange.Rows.Count - 1)
    Set rf = shP.Cells(1, 5).Resize(rp.Rows.Count)
    prr = rp.Value
    frr = rf.Formula
    
    Dim cs As Range, sName As String, dValue As Variant
    For Each cs In Intersect(Target, Range("C2").Resize(ActiveSheet.UsedRange.Rows.Count - 1)).Cells
        If IsNumeric(cs.Value) Then
            dValue = cs.Value
            sName = cs.EntireRow.Cells(1, 1).Value
            If sName <> "" Then
                For yp = 2 To UBound(prr, 1)
                    If prr(yp, 1) = sName Then
                        If frr(yp, 1) <> dValue Then
                            frr(yp, 1) = dValue
                            flag = True
                        End If
                    End If
                Next
            End If
        End If
    Next
    
    If flag Then
        rf.Formula = frr
    End If
End Sub

'v3
Sub ZapRozdav2()
    Dim shTarget As Worksheet
    Set shTarget = Sheets("Таблица")

    Dim tbSource As ListObject
    Set tbSource = Sheets("Движение").ListObjects("tb_RozdZdavVid")
    
    Dim aSource As Variant
    ReDim aSource(1 To 4)
    aSource(1) = tbSource.ListColumns("Наименование").DataBodyRange.Value
    aSource(2) = tbSource.ListColumns("Признак").DataBodyRange.Value
    aSource(3) = tbSource.ListColumns("Цена").DataBodyRange.Value
    aSource(4) = tbSource.ListColumns("Кол-во").DataBodyRange.Value
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim ys As Long, yt As Long, xt As Long
    For ys = 1 To UBound(aSource(1), 1)
        yt = GetYTarget(shTarget, aSource(1)(ys, 1))
        xt = GetXTarget(shTarget, aSource(2)(ys, 1), aSource(4)(ys, 1), 10)
        shTarget.Cells(yt, xt).Value = aSource(3)(ys, 1)
        'shTarget.Cells(10, xt).Value = aSource(4)(ys, 1)
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Function GetYTarget(sh As Worksheet, ByVal sName As String) As Long
    Const xx = 2
    
    Dim yt As Long
    On Error Resume Next
    yt = WorksheetFunction.Match(sName, sh.Columns(xx), 0)
    On Error GoTo 0
    If yt > 0 Then
        GetYTarget = yt
        Exit Function
    End If
    
    Dim blockRowsCount As Long
    
    yt = 12
    blockRowsCount = 0
    Do
        If IsEmpty(sh.Cells(yt, xx).Value) Then
            sh.Cells(yt, xx).Value = sName
            GetYTarget = yt
            Exit Function
        End If
        blockRowsCount = blockRowsCount + 1
        If blockRowsCount = 7 Then
            yt = yt + 31 - 12 - blockRowsCount + 1
            blockRowsCount = 0
        Else
            yt = yt + 1
        End If
        DoEvents
    Loop
End Function

Private Function GetXTarget(sh As Worksheet, ByVal sName As String, ByVal sSort As String, ySort As Long) As Long
    Const xx = 8
    
    Dim yt As Long
    yt = 5
    Do
        If sh.Cells(xx, yt).Value = sName Then
            If sh.Cells(ySort, yt).Value = sSort Then
                GetXTarget = yt
                Exit Function
            End If
        End If
        
        yt = yt + 1
        If yt > sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1 Then Exit Do
        DoEvents
    Loop
    
    Dim blockRowsCount As Long
    
    yt = 5
    Do
        If IsEmpty(sh.Cells(xx, yt).Value) Then
            sh.Cells(xx, yt).Value = sName
            sh.Cells(ySort, yt).Value = sSort
            GetXTarget = yt
            Exit Function
        End If
        
        yt = yt + 1
        DoEvents
    Loop
End Function

Option Explicit
'v2
Sub ZapRozdav2()
    Dim shTarget As Worksheet
    Set shTarget = Sheets("Таблица")

    Dim tbSource As ListObject
    Set tbSource = Sheets("Движение").ListObjects("tb_RozdZdavVid")
    
    Dim aSource As Variant
    ReDim aSource(1 To 4)
    aSource(1) = tbSource.ListColumns("Наименование").DataBodyRange.Value
    aSource(2) = tbSource.ListColumns("Признак").DataBodyRange.Value
    aSource(3) = tbSource.ListColumns("Цена").DataBodyRange.Value
    aSource(4) = tbSource.ListColumns("Кол-во").DataBodyRange.Value
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim ys As Long, yt As Long, xt As Long
    For ys = 1 To UBound(aSource(1), 1)
        yt = GetYTarget(shTarget, aSource(1)(ys, 1))
        xt = GetXTarget(shTarget, aSource(2)(ys, 1))
        shTarget.Cells(yt, xt).Value = aSource(3)(ys, 1)
        shTarget.Cells(10, xt).Value = aSource(4)(ys, 1)
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Function GetYTarget(sh As Worksheet, ByVal sName As String) As Long
    Const xx = 2
    
    Dim yt As Long
    On Error Resume Next
    yt = WorksheetFunction.Match(sName, sh.Columns(xx), 0)
    On Error GoTo 0
    If yt > 0 Then
        GetYTarget = yt
        Exit Function
    End If
    
    Dim blockRowsCount As Long
    
    yt = 12
    blockRowsCount = 0
    Do
        If IsEmpty(sh.Cells(yt, xx).Value) Then
            sh.Cells(yt, xx).Value = sName
            GetYTarget = yt
            Exit Function
        End If
        blockRowsCount = blockRowsCount + 1
        If blockRowsCount = 7 Then
            yt = yt + 31 - 12 - blockRowsCount + 1
            blockRowsCount = 0
        Else
            yt = yt + 1
        End If
        DoEvents
    Loop
End Function

Private Function GetXTarget(sh As Worksheet, ByVal sName As String) As Long
    Const xx = 8
    
    Dim yt As Long
    On Error Resume Next
    yt = WorksheetFunction.Match(sName, sh.Rows(xx), 0)
    On Error GoTo 0
    If yt > 0 Then
        GetXTarget = yt
        Exit Function
    End If
    
    Dim blockRowsCount As Long
    
    yt = 5
    Do
        If IsEmpty(sh.Cells(xx, yt).Value) Then
            sh.Cells(xx, yt).Value = sName
            GetXTarget = yt
            Exit Function
        End If
        
        yt = yt + 1
        DoEvents
    Loop
End Function

=СУММЕСЛИМН($S$11:$S$346;$K$11:$K$346;"Монтаж технологических трубопроводов (Ду 89мм)")
+СУММЕСЛИМН($S$11:$S$346;$K$11:$K$346;"Монтаж технологических трубопроводов (Ду 159мм)")

=СУММЕСЛИМН($S$11:$S$346;$K$11:$K$346;K357&"*")

=ИНДЕКС($C$15:$G$15;ПОИСКПОЗ(J4;$C$3:$G$3;0))

=ГПР(J:J;$3:$15;13;0)

=СУММЕСЛИМН(СМЕЩ($B$4:$B$13;0;ПОИСКПОЗ(J4;$C$3:$G$3;0));$A$4:$A$13;$K$3)

Sub ZapRozdav2()
    Dim shTarget As Worksheet
    Set shTarget = Sheets("Таблица")

    Dim tbSource As ListObject
    Set tbSource = Sheets("Движение").ListObjects("tb_RozdZdavVid")
    
    Dim aSource As Variant
    ReDim aSource(1 To 3)
    aSource(1) = tbSource.ListColumns("Наименование").DataBodyRange.Value
    aSource(2) = tbSource.ListColumns("Признак").DataBodyRange.Value
    aSource(3) = tbSource.ListColumns("Цена").DataBodyRange.Value
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim ys As Long, yt As Long, xt As Long
    For ys = 1 To UBound(aSource(1), 1)
        yt = GetYTarget(shTarget, aSource(1)(ys, 1))
        xt = GetXTarget(shTarget, aSource(2)(ys, 1))
        shTarget.Cells(yt, xt).Value = aSource(3)(ys, 1)
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Function GetYTarget(sh As Worksheet, ByVal sName As String) As Long
    Const xx = 2
    
    Dim yt As Long
    On Error Resume Next
    yt = WorksheetFunction.Match(sName, sh.Columns(xx), 0)
    On Error GoTo 0
    If yt > 0 Then
        GetYTarget = yt
        Exit Function
    End If
    
    Dim blockRowsCount As Long
    
    yt = 12
    blockRowsCount = 0
    Do
        If IsEmpty(sh.Cells(yt, xx).Value) Then
            sh.Cells(yt, xx).Value = sName
            GetYTarget = yt
            Exit Function
        End If
        blockRowsCount = blockRowsCount + 1
        If blockRowsCount = 7 Then
            yt = yt + 31 - 12 - blockRowsCount + 1
            blockRowsCount = 0
        Else
            yt = yt + 1
        End If
        DoEvents
    Loop
End Function

Private Function GetXTarget(sh As Worksheet, ByVal sName As String) As Long
    Const xx = 8
    
    Dim yt As Long
    On Error Resume Next
    yt = WorksheetFunction.Match(sName, sh.Rows(xx), 0)
    On Error GoTo 0
    If yt > 0 Then
        GetXTarget = yt
        Exit Function
    End If
    
    Dim blockRowsCount As Long
    
    yt = 5
    Do
        If IsEmpty(sh.Cells(xx, yt).Value) Then
            sh.Cells(xx, yt).Value = sName
            GetXTarget = yt
            Exit Function
        End If
        
        yt = yt + 1
        DoEvents
    Loop
End Function

Sub triming()
   Dim trim_range  As Range
   Set trim_range = Range("B:B")
   Set trim_range = Intersect(trim_range, ActiveSheet.UsedRange)
   trim_range.Select
   With trim_range
    If .Cells.CountLarge = 1 Then
        .Value = Application.Trim(.Value)
    Else
        Dim arr As Variant, ya As Long, xa As Long
        arr = .Value
        For ya = 1 To UBound(arr, 1)
            For xa = 1 To UBound(arr, 2)
                arr(ya, xa) = Application.Trim(arr(ya, xa))
            Next
        Next
        .Value = arr
    End If
   End With
End Sub

Sub triming()
   Dim trim_range  As Range
   Set trim_range = Range("B:B")
   Set trim_range = Intersect(trim_range, ActiveSheet.UsedRange)
   trim_range.Select
   With trim_range
    If .Cells.CountLarge = 1 Then
        .Value = Application.Trim(.Value)
    Else
        Dim arr As Variant, ya As Long, xa As Long
        arr = .Value
        For ya = 1 To UBound(arr, 1)
            For xa = 1 To UBound(arr, 2)
                arr(ya, xa) = Application.Trim(arr(ya, xa))
            Next
        Next
        arr = .Value
    End If
   End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A2").Resize(ActiveSheet.UsedRange.Rows.Count)) Is Nothing Then
        Dim cl As Range, ce As Range
        For Each cl In Intersect(Target, Range("A2").Resize(ActiveSheet.UsedRange.Rows.Count)).Cells
            Set ce = cl.Range("E1")
            If IsEmpty(cl.Value) Then
                ce.ClearContents
            Else
                ce.FormulaR1C1 = "=IF(IFERROR(VLOOKUP(RC[-2],Перечень!R2C1:R150C3,3,0),"""")=0,"""",IFERROR(VLOOKUP(RC[-2],Перечень!R2C1:R150C3,3,0),""""))"
                ce.Value = ce.Value
                If ce.Value = "" Then ce.ClearContents
            End If
        Next
    End If
End Sub

c.FormulaLocal = Replace(c.FormulaLocal, "[" & ThisWorkbook.Name & "]", "")
c.Value = c.Value

wb.Worksheets("Средства измерений").Range(ThisWorkbook.Worksheets("Средства измерений").UsedRange.Address(0, 0, xlA1)).Value = ThisWorkbook.Worksheets("Средства измерений").UsedRange.Value

wb.Worksheets("Средства измерений").UsedRange.Value = wb.Worksheets("Средства измерений").UsedRange.Value
wb.Close (True)

Option Explicit
Private dicValidation As Object

Private Sub Worksheet_Activate()
    Set dicValidation = GetValidationDic(sheetName:="База", tableName:="База")
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tb As ListObject
    Set tb = ActiveSheet.ListObjects(1)
    If Intersect(Target, tb.DataBodyRange) Is Nothing Then Exit Sub
    
    If dicValidation Is Nothing Then
        Set dicValidation = GetValidationDic(sheetName:="База", tableName:="База")
    End If
    
    Dim cl As Range
    For Each cl In Intersect(Target, tb.DataBodyRange).Cells
        FillCellValidation cl, tb.DataBodyRange, dicValidation
    Next
End Sub

Private Sub FillCellValidation(cl As Range, rTable As Range, dicValidation As Object)
    Dim aValid As Variant
    If cl.Column = rTable.Column + rTable.Columns.Count - 1 Then Exit Sub
    
    Dim dic As Object, xt As Long, ct As Range
    For xt = 1 To rTable.Columns.Count - 1
        Set ct = cl.EntireRow.Cells(1, rTable.Column - 1 + xt)
        
        If xt = rTable.Column Then
            Set dic = dicValidation
        Else
            If Not dic Is Nothing Then
                If dic.Exists(ct.Cells(1, 0).Value) Then
                    Set dic = dic(ct.Cells(1, 0).Value)
                Else
                    Set dic = Nothing
                End If
            End If
        End If
        With ct.Validation
            .Delete
            If Not dic Is Nothing Then
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(dic.Keys(), ",")
                .IgnoreBlank = True: .InCellDropdown = True: .InputTitle = "": .ErrorTitle = "": .InputMessage = "": .ErrorMessage = "": .ShowInput = True: .ShowError = True
            End If
        End With
    Next
End Sub

Private Function GetValidationDic(sheetName As String, tableName As String) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim baza As Variant
    baza = Sheets("База").ListObjects("База").DataBodyRange
    Dim yb As Long
    For yb = 1 To UBound(baza, 1)
        DicAddRecu dic, 1, baza, yb
    Next
    Set GetValidationDic = dic
End Function

Private Sub DicAddRecu(dic As Object, level As Long, arr As Variant, ya As Long)
    If Not dic.Exists(arr(ya, level)) Then
        Set dic.Item(arr(ya, level)) = CreateObject("Scripting.Dictionary")
    End If
    If level < UBound(arr, 2) Then
        Dim bic As Object
        Set bic = dic.Item(arr(ya, level))
        DicAddRecu bic, level + 1, arr, ya
        
        Set dic.Item(arr(ya, level)) = bic
    End If
End Sub

Sub DeleteMergedRows()
    Dim myRange As Range
    Set myRange = Range("A100:A124")
    Range("A100").Resize(ActiveSheet.UsedRange.Rows.Count).UnMerge
    'или так myRange.Resize(ActiveSheet.UsedRange.Rows.Count).UnMerge
    myRange.EntireRow.Hidden = False
    'myRange.UnMerge
    myRange.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlShiftUp
End Sub