Private Sub Worksheet_Change(ByVal Target As Range)
i = Target.Row
If Range("F" & i).Value <> "передано" Then Exit Sub
ActiveSheet.Unprotect
Range("C" & i & ":H" & i).Locked = True
ActiveSheet.Protect
End Sub

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