Option Explicit
 
Sub Копировать_значения_только_в_путь_в_определенной_ячейки()
    Dim rSheets As Range, journalFullname As String, sourceRange As Range
    Set rSheets = ThisWorkbook.Sheets("Подборка").UsedRange.Rows(1)
    journalFullname = ThisWorkbook.Sheets("Расположение").Range("G4").Value
    Set sourceRange = ThisWorkbook.Sheets("Данные").UsedRange
     
    CopyRange rSheets, journalFullname, sourceRange
End Sub
 
Private Sub CopyRange(rSheets As Range, journalFullname As String, sourceRange As Range)
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
     
    Dim journal As Workbook
    On Error Resume Next
    Set journal = Workbooks.Open(journalFullname)
    If journal Is Nothing Then
        MsgBox Err.Description, vbExclamation, "Ошибка открытия файла"
    End If
    On Error GoTo 0
    If Not journal Is Nothing Then
        Set rSheets = Intersect(rSheets, rSheets.Parent.UsedRange)
        Set sourceRange = Intersect(sourceRange, sourceRange.Parent.Range("A3").Resize(sourceRange.Parent.UsedRange.Rows.Count, sourceRange.Parent.UsedRange.Columns.Count))
         
        CopyJournal rSheets, journal, sourceRange
        Application.Calculation = Application_Calculation
         
        journal.Close True
    Else
        Application.Calculation = Application_Calculation
    End If
End Sub
 
Private Sub CopyJournal(rSheets As Range, journal As Workbook, sourceRange As Range)
    Dim clSheet As Range, shTarget As Worksheet, rTarget As Range
    For Each clSheet In rSheets.Cells
        On Error Resume Next
        Set shTarget = journal.Worksheets(clSheet.Value)
        On Error GoTo 0
        If Not shTarget Is Nothing Then
            Set rTarget = GetTargetRange(shTarget, sourceRange)
            Set rTarget = rTarget.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
            sourceRange.Copy rTarget
            Application.CutCopyMode = False
            rTarget.Value = sourceRange.Value
             
            Set shTarget = Nothing
        End If
    Next
End Sub
 
Private Function GetTargetRange(sh As Worksheet, sourceRange As Range) As Range
    Set GetTargetRange = GetTargetRange_Exists(sh, sourceRange)
    If Not GetTargetRange Is Nothing Then Exit Function
    Set GetTargetRange = GetTargetRange_New(sh)
End Function

Private Function GetTargetRange_Exists(sh As Worksheet, sourceRange As Range) As Range
    Dim yy As Long
    For yy = 2 To sh.UsedRange.Rows.Count
        If sh.Cells(yy, 1).Value = sourceRange.Cells(1, 1).Value Then
        If sh.Cells(yy, 2).Value = sourceRange.Cells(1, 2).Value Then
        If sh.Cells(yy, 3).Value = sourceRange.Cells(1, 3).Value Then
            Set GetTargetRange_Exists = sh.Cells(yy, 1)
            AddRows sh.Cells(yy, 1), sourceRange.Rows.Count
            Exit Function
        End If
        End If
        End If
    Next
End Function

Private Sub AddRows(rr As Range, nRows As Long)
    Dim sh As Worksheet
    Set sh = rr.Parent
    
    Dim cd As Range
    Set cd = rr.End(xlDown)
    If cd.Row >= sh.Rows.Count - 2 Then Exit Sub
    
    Do
        If cd.Row >= rr.Row + nRows Then Exit Do
        cd.EntireRow.Insert
        DoEvents
    Loop
    
    Do
        If cd.Row - 1 <= rr.Row + nRows Then Exit Do
        cd.Cells(0, 1).EntireRow.Delete
        DoEvents
    Loop
End Sub

Private Function GetTargetRange_New(sh As Worksheet) As Range
    Dim cl As Range, yy As Long, ym As Long
    ym = 1
    For Each cl In sh.UsedRange.Rows(sh.UsedRange.Rows.Count + 2).Cells
        yy = cl.End(xlUp).Row + 1
        If ym < yy Then ym = yy
    Next
    Set GetTargetRange_New = sh.Cells(ym, 1)
End Function

=ОКРУГЛ(0,5*(E10+0,5)-5,5;0)

Option Explicit
 
Sub Копировать_значения_только_в_путь_в_определенной_ячейки()
    Dim rSheets As Range, journalFullname As String, sourceRange As Range
    Set rSheets = ThisWorkbook.Sheets("Подборка").UsedRange.Rows(1)
    journalFullname = ThisWorkbook.Sheets("Расположение").Range("G4").Value
    Set sourceRange = ThisWorkbook.Sheets("Данные").UsedRange
     
    CopyRange rSheets, journalFullname, sourceRange
End Sub
 
Private Sub CopyRange(rSheets As Range, journalFullname As String, sourceRange As Range)
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
     
    Dim journal As Workbook
    On Error Resume Next
    Set journal = Workbooks.Open(journalFullname)
    If journal Is Nothing Then
        MsgBox Err.Description, vbExclamation, "Ошибка открытия файла"
    End If
    On Error GoTo 0
    If Not journal Is Nothing Then
        Set rSheets = Intersect(rSheets, rSheets.Parent.UsedRange)
        Set sourceRange = Intersect(sourceRange, sourceRange.Parent.Range("A3").Resize(sourceRange.Parent.UsedRange.Rows.Count, sourceRange.Parent.UsedRange.Columns.Count))
         
        CopyJournal rSheets, journal, sourceRange
        Application.Calculation = Application_Calculation
         
        journal.Close True
    Else
        Application.Calculation = Application_Calculation
    End If
End Sub
 
Private Sub CopyJournal(rSheets As Range, journal As Workbook, sourceRange As Range)
    Dim clSheet As Range, shTarget As Worksheet, rTarget As Range
    For Each clSheet In rSheets.Cells
        On Error Resume Next
        Set shTarget = journal.Worksheets(clSheet.Value)
        On Error GoTo 0
        If Not shTarget Is Nothing Then
            Set rTarget = GetTargetRange(shTarget, sourceRange)
            Set rTarget = rTarget.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
            sourceRange.Copy rTarget
            Application.CutCopyMode = False
            rTarget.Value = sourceRange.Value
             
            Set shTarget = Nothing
        End If
    Next
End Sub
 
Private Function GetTargetRange(sh As Worksheet, sourceRange As Range) As Range
    Set GetTargetRange = GetTargetRange_Exists(sh, sourceRange)
    If Not GetTargetRange Is Nothing Then Exit Function
    Set GetTargetRange = GetTargetRange_New(sh)
End Function

Private Function GetTargetRange_Exists(sh As Worksheet, sourceRange As Range) As Range
    Dim yy As Long
    For yy = 2 To sh.UsedRange.Rows.Count
        If sh.Cells(yy, 1).Value = sourceRange.Cells(1, 1).Value Then
        If sh.Cells(yy, 2).Value = sourceRange.Cells(1, 2).Value Then
        If sh.Cells(yy, 3).Value = sourceRange.Cells(1, 3).Value Then
            Set GetTargetRange_Exists = sh.Cells(yy, 1)
            Exit Function
        End If
        End If
        End If
    Next
End Function

Private Function GetTargetRange_New(sh As Worksheet) As Range
    Dim cl As Range, yy As Long, ym As Long
    ym = 1
    For Each cl In sh.UsedRange.Rows(sh.UsedRange.Rows.Count + 2).Cells
        yy = cl.End(xlUp).Row + 1
        If ym < yy Then ym = yy
    Next
    Set GetTargetRange_New = sh.Cells(ym, 1)
End Function

Option Explicit

Sub Напечатать_протоколы()
    CloseEmptyWb
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    
    Dim protocols As Object
    Set protocols = GetProtocols(wb.Sheets("Данные"))
    
    Dim protocol_index As Long
    For protocol_index = 1 To protocols.Count - 1
        PrintProtocol protocols, protocol_index, wb.Sheets("Прот")
    Next
End Sub

Private Sub PrintProtocol(protocols As Object, protocol_index As Long, shTemplate As Worksheet)
    shTemplate.Copy
    Dim sh As Worksheet
    Set sh = ActiveSheet
    
    sh.Cells(4, 20).Value = protocols.Keys()(protocol_index)
    
    Dim aHead As Variant, aValu As Variant
    aHead = protocols.Items()(0).Items()(0)
    aValu = protocols.Items()(protocol_index).Items()
    
    Dim yy As Long
    For yy = 0 To UBound(aValu, 1)
        If yy >= 10 Then
            sh.Rows(28 + yy - 1).Copy
            sh.Rows(28 + yy - 1).Insert Shift:=xlDown
            Application.CutCopyMode = False
            sh.Cells(28 + yy, 1).Value = (yy + 1) & "."
        End If
        sh.Cells(28 + yy, 3).Value = aValu(yy)(1, 1)
        sh.Cells(28 + yy, 16).Value = aValu(yy)(1, 2)
        sh.Cells(28 + yy, 23).Value = aValu(yy)(1, 3)
        sh.Cells(28 + yy, 31).Value = aValu(yy)(1, 4)
        sh.Cells(28 + yy, 37).Value = aValu(yy)(1, 5)
    Next
    sh.PrintOut
End Sub

Private Function GetProtocols(sh As Worksheet) As Object
    Dim rr As Range
    Set rr = sh.Cells(1, 1).Resize(sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1, sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1)
    
    Dim rp As Range
    Set rp = rr.Find("Номер протокола")
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long, bic As Object, vv As Variant
    For ya = rp.Row To rr.Rows.Count
        vv = rr.Cells(ya, rp.Column).Value
        If Not dic.Exists(vv) Then
            Set dic.Item(vv) = CreateObject("Scripting.Dictionary")
        End If
        Set bic = dic.Item(vv)
        bic.Item(bic.Count) = rr.Cells(ya, 1).Resize(1, rr.Columns.Count).Value
        Set dic.Item(vv) = bic
        Set bic = Nothing
    Next
    Set GetProtocols = dic
End Function

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

=ЕСЛИ(И(ОСТАТ(СЧЁТЕСЛИМН($A$1:$A2;"<>")-1;7)+1=B$1;$A2<>"");$A2;"")

=СЧЁТЕСЛИМН($H$2:H2;H2;$D$2:D2;">0")+СЧЁТЕСЛИМН($H$2:H2;H2;$E$2:E2;">0")+СЧЁТЕСЛИМН($H$2:H2;H2;$F$2:F2;">0")-
СЧЁТЕСЛИМН($H$2:H2;H2;$D$2:D2;">0";$E$2:E2;">0")-СЧЁТЕСЛИМН($H$2:H2;H2;$D$2:D2;">0";$F$2:F2;">0")-СЧЁТЕСЛИМН($H$2:H2;H2;$E$2:E2;">0";$F$2:F2;">0")+
СЧЁТЕСЛИМН($H$2:H2;H2;$D$2:D2;">0";$E$2:E2;">0";$F$2:F2;">0")

=ИНДЕКС(prices!$C$1:$C$38;МАКС((Table125[@Type]=prices!$A$5:$A$38)*(ЗНАЧЕН(Table125[@GSM])>=prices!$B$5:$B$38)*(СТРОКА(prices!$A$5:$A$38))))+ЕСЛИ(Table125[@[F?]]="YES";prices!$B$1;0)

=СЧЁТЕСЛИМН($A$2:A2;"сентябрь";$B$2:B2;"Яблоки";$C$2:C2;"Зеленый")

Option Explicit
Private Const SOURCE_SHEET_NAME = "Лист1"
Private Const TARGET_SHEET_NAME = "Лист2"

Private Sub Worksheet_Activate()
    Dim shSource As Worksheet, shTarget As Worksheet
    Set shSource = Sheets(SOURCE_SHEET_NAME)
    Set shTarget = Sheets(TARGET_SHEET_NAME)
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    shSource.UsedRange.Copy shTarget.Range(shSource.UsedRange.Address(0, 0, xlA1))
    ClearUsedRange shTarget, shSource.UsedRange.Address(0, 0, xlA1)
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub ClearUsedRange(sh As Worksheet, sAddress As String)
    Dim rExcept As Range
    Set rExcept = sh.Range(sAddress)
    
    Dim cl As Range, rUnion As Range
    For Each cl In sh.UsedRange.Cells
        If Intersect(cl, rExcept) Is Nothing Then
            myUnion rUnion, cl
        End If
    Next
    
    If rUnion Is Nothing Then Exit Sub
    For Each cl In rUnion.Areas
        cl.Clear
    Next
End Sub

Private Sub myUnion(rUnion As Range, cl As Range)
    If rUnion Is Nothing Then
        Set rUnion = cl
    Else
        Set rUnion = Union(rUnion, cl)
    End If
End Sub

On Error Resume Next
Set tbSource = Sheets("Движение").ListObjects("tb_RozdZdavVid")
On Error Goto 0
If tbSource Is Nothing then exit sub

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&"*")