If (z - f + 1) > V Then OTCH.Rows(x).Insert Shift:=xlDown : V = V + 1

Application.DisplayAlerts = False

Application.DisplayAlerts = True

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 9 Then Exit Sub
Dim cl As Range
For Each cl In Range("A" & Target.Row & ":H" & Target.Row)
    If cl.Value = "" Then
        Application.EnableEvents = False
        Target = ""
        MsgBox ("Заполнены не все поля")
        Application.EnableEvents = True
        Exit Sub
    End If
Next
With Worksheets(Target.Value)
    k = .Cells(Rows.Count, "A").End(xlUp).Row + 1
    .Range("A" & k & ":I" & k).Value = Range("A" & Target.Row & ":I" & Target.Row).Value
End With
End Sub

Sub nz()
Dim cl As Range
For Each cl In Range("G2:G" & Cells(Rows.Count, "G").End(xlUp).Row)
    If Mid(cl, 12, 1) <> "&" Then cl.Offset(0, -4) = Replace(Mid(cl, 12, 6), ".", "")
Next
End Sub

Sub nz()
Dim cl As Range
For Each cl In Range("G2:G" & Cells(Rows.Count, "G").End(xlUp).Row)
    If Mid(cl, 12, 1) <> "&" Then cl.Offset(0, -4) = Mid(cl, 12, 6)
Next
End Sub

Sub sbor()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Worksheet, wb As Workbook
Set sh = ActiveSheet
i = 3
Do While sh.Cells(i, 1).Value <> ""
    pth = sh.Cells(i, 1).Value & "\" & sh.Cells(i, 3).Value
    Set wb = Workbooks.Open(pth, , , , sh.Cells(i, 2).Value)
        wb.Worksheets(sh.cells(i,4).value).Copy after:=sh
    wb.Close 0
    i = i + 1
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Sub sbor()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Worksheet, wsh As Worksheet, wb As Workbook
Set sh = ActiveSheet
i = 3
Do While sh.Cells(i, 1).Value <> ""
    pth = sh.Cells(i, 1).Value & "\" & sh.Cells(i, 3).Value
    Set wb = Workbooks.Open(pth, , , , sh.Cells(i, 2).Value)
    For Each wsh In wb.Worksheets
        wsh.Copy after:=sh
    Next
    wb.Close 0
    i = i + 1
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Sub d()
Application.ScreenUpdating = False
Dim dic
Set dic = CreateObject("Scripting.Dictionary")
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, 3).Value = "На согласовании" Or Cells(i, 3).Value = "Не требует согласования" Then
        ky = Cells(i, 1).Value
        it = Cells(i, 2).Value & "|" & Cells(i, 3).Value
        If dic.exists(ky) Then dic.Item(ky) = it Else dic.Add ky, it
    End If
Next
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, 3).Value = "Согласован" Or Cells(i, 3).Value = "Не требует согласования" Then
        ky = Cells(i, 1).Value
        s = Split(dic.Item(ky), "|")
        dic.Item(ky) = s(LBound(s)) & "|" & Cells(i, 2).Value
    End If
Next
i = 2
For Each ky In dic.keys
    s = Split(dic.Item(ky), "|")
    Range("E" & i) = ky
    Range("F" & i) = s(LBound(s))
    Range("G" & i) = s(UBound(s))
    i = i + 1
Next
Application.ScreenUpdating = True
End Sub