Sub NewSheetonList()
Dim i As Long, i_n As Long, n As Long, i1 As Long
Dim Podrazd() As String, sovpal As Long
i_n = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row

ReDim Podrazd(i_n - 1)
Dim k As Long
k = 1
For i = 2 To i_n
   k = k + 1
   sovpal = 0
   Podrazd(i - 1) = Worksheets(1).Cells(i, 1)
   For n = 1 To k - 2
     If Podrazd(n) <> "" Then
      If Podrazd(n) = Podrazd(i - 1) Then
         sovpal = sovpal + 1
      End If
     End If
   Next n
   If sovpal = 0 Then
     Worksheets.Add after:=Worksheets(Worksheets.Count)
     Worksheets(Worksheets.Count).name = Podrazd(i - 1)
     Worksheets(1).Cells(1, 1).Resize(, 7).Copy Worksheets(Worksheets.Count).Cells(1, 1)
     i1 = i
     s = 0
     Do
     i1 = i1 + 1
     s = s + 1
     Loop While Worksheets(1).Cells(i1, 1) = Podrazd(i - 1)
     Worksheets(1).Cells(i1 - s, 1).Resize(s, 7).Copy Worksheets(Worksheets.Count).Cells(2, 1)
   End If
Next i
End Sub