Sub Разделение()
Dim i&, i_n&, k&, k2&
Dim WB As Workbook, TWB As Workbook
Dim path1$
Dim o As Object, key$, pthkey$
Set TWB = ThisWorkbook
path1 = TWB.Path & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
i_n = TWB.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
Set o = CreateObject("Scripting.dictionary")
For i = 2 To i_n
   key = TWB.Worksheets(1).Cells(i, 2)
   If Not o.exists(key) Then
      k = k + 1
      If k > 1 Then
         WB.SaveAs Filename:=path1 & pthkey & ".xlsx"
         WB.Close
      End If
      Set WB = Workbooks.Add
      TWB.Worksheets(1).Rows(1).Copy
      WB.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
      TWB.Worksheets(1).Rows(1).Copy
      WB.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteAll
      WB.Worksheets(1).Cells(1, 1).Resize(, 7).AutoFilter
      o.Add key, k
      pthkey = key
      k2 = 1
   End If
   k2 = k2 + 1
   TWB.Worksheets(1).Rows(i).Copy WB.Worksheets(1).Cells(k2, 1)
Next i
WB.SaveAs Filename:=path1 & pthkey & ".xlsx"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub d()
    Dim sh As Worksheet, rng As Range
    ActiveSheet.Copy
    With ActiveWorkbook
        Set sh = .Sheets(1)
        On Error Resume Next
        Do Until Err
            Set rng = sh.[b2].Resize(sh.Rows.Count - 1).ColumnDifferences(sh.[b2])
            If Err = 0 Then Sheets.Add , sh
            sh.[1:1].Copy sh.Next.[1:1]: rng.EntireRow.Cut sh.Next.[A2]
            sh.[1:1].Copy: sh.Next.[1:1].PasteSpecial (xlPasteColumnWidths)
            sh.SaveAs "D:\папка\" & sh.[b2] & ".xlsx": Set sh = sh.Next
        Loop
        .Close False
    End With
End Sub

Sub Разделение()
Dim i&, i_n&, k&, k2&
Dim WB As Workbook, TWB As Workbook
Dim path1$
Dim o As Object, key$, pthkey$
Dim ft$
ft = ".xls"
Set TWB = ThisWorkbook
path1 = TWB.Path & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
i_n = TWB.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
Set o = CreateObject("Scripting.dictionary")
For i = 2 To i_n
key = TWB.Worksheets(1).Cells(i, 2)
If Not o.exists(key) Then
    k = k + 1
    If k > 1 Then
        WB.SaveAs Filename:=path1 & pthkey & ft
        WB.Close
    End If
    Set WB = Workbooks.Add
    TWB.Worksheets(1).Rows(1).Copy
    WB.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
    TWB.Worksheets(1).Rows(1).Copy
    WB.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteAll
    WB.Worksheets(1).Cells(1, 1).Resize(, 7).AutoFilter
    o.Add key, k
    pthkey = key
    k2 = 1
End If
k2 = k2 + 1
TWB.Worksheets(1).Rows(i).Copy WB.Worksheets(1).Cells(k2, 1)
Next i
WB.SaveAs Filename:=path1 & pthkey & ft
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

ft = ".xls"