Sub Start()
Dim i As Long, j As Long, ok As Boolean
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For i = 4 To Cells(3, 2).End(xlDown).Row
       For j = 1 To Sheets.Count
          If Sheets(j).Name = Replace(Sheets(1).Cells(i, 2), "/", "_") Then
             Sheets(1).Rows(i).Copy (Sheets(j).Range("A" & Sheets(j).Cells(1, 2).End(xlDown).Row + 1))
             ok = True
          End If
       Next j
       If ok = False Then
          Sheets.Add After:=Sheets(Sheets.Count)
          Sheets(Sheets.Count).Name = Replace(Sheets(1).Cells(i, 2), "/", "_")
          Sheets(1).Rows(3).Copy
          Sheets(Sheets.Count).Rows(1).PasteSpecial Paste:=xlPasteColumnWidths
          Sheets(1).Rows(3).Copy (Sheets(Sheets.Count).Range("A1"))
          Sheets(1).Rows(i).Copy (Sheets(Sheets.Count).Range("A2"))
          Sheets(Sheets.Count).Range("A1").Select
       End If
       ok = False
    Next i
    Call createBooks
    Call delNewSheets
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Private Sub createBooks()
    Dim i As Long
    Dim nmshule As String
     
    For i = 2 To Sheets.Count
        Sheets(i).Select
        nmshule = Sheets(i).Name
        Sheets(i).UsedRange.Select
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Columns("H:H").EntireColumn.AutoFit
        Columns("P:P").EntireColumn.AutoFit
        Sheets("Лист1").Select
        Sheets("Лист1").Name = nmshule
        Application.CutCopyMode = False
       
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & nmshule & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
             
         ActiveWorkbook.Close 0
    Next i
End Sub

Private Sub delNewSheets()
     Dim i As Long
     For i = Sheets.Count To 2 Step -1
        Sheets(i).Delete
     Next i
End Sub

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & nmshule & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False