Sub obrabotka()


FileOpen = Application.GetOpenFilename
    If FileOpen <> False Then
        Workbooks.Open (FileOpen)
        Else: Exit Sub
    End If

Application.ScreenUpdating = False

For i = 2 To Worksheets(1).Cells(Rows.Count, 4).End(xlUp).Row

        imya = Worksheets(1).Cells(i, 4)
        If Not SheetExist(imya) Then
        Sheets.Add after:=Sheets(1)
        ActiveSheet.Name = imya
        Worksheets(imya).Rows(1).Value = Worksheets(1).Rows(1).Value
        Worksheets(imya).Rows(Sheets(imya).Cells(Rows.Count, 4).End(xlUp).Row + 1).Value = Worksheets(1).Rows(i).Value
        
        Else
        Worksheets(imya).Rows(Sheets(imya).Cells(Rows.Count, 4).End(xlUp).Row + 1).Value = Worksheets(1).Rows(i).Value
        End If
    Next i

 For i = 2 To Sheets.Count
     Worksheets(i).Copy
     MsgBox Sheets(1).Name
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Replace(Sheets(1).Name, """", "_") & ".xlsx"

    ActiveWorkbook.Close
Next i

Application.ScreenUpdating = True

End Sub
 
Public Function SheetExist(ShName)
    Dim sh As Worksheet
    On Error Resume Next
        Set sh = Worksheets(ShName)
        SheetExist = Not (Err.Number <> 0)
    On Error GoTo 0

End Function