Sub Разбивка()
Dim wbNewBook As Workbook, wbCurrBook As Workbook, lRow As Long, _
lFirstRow As Long, lLastRow As Long
Set wbCurrBook = Workbooks("Current.xlsx")
lLastRow = wbCurrBook.Sheets( 1 ).UsedRange.Rows.Count
lFirstRow =  2 
For lRow =  2  To lLastRow
    If wbCurrBook.Sheets( 1 ).Cells(lFirstRow,  2 ) <> wbCurrBook.Sheets( 1 ).Cells(lRow +  1 ,  2 ) Then
        Set wbNewBook = Workbooks.Add '(-4167)
        wbNewBook.SaveAs ThisWorkbook.Path & "\Out\" & wbCurrBook.Sheets( 1 ).Cells(lFirstRow,  2 ), FileFormat:=xlExcel8
        wbNewBook.Sheets( 1 ).Cells( 1 ,  1 ) = wbCurrBook.Sheets( 1 ).Range(Cells( 1 ,  1 ), Cells( 1 ,  19 ))
        wbNewBook.Sheets( 1 ).Cells( 2 ,  1 ) = wbCurrBook.Sheets( 1 ).Range(Cells(lFirstRow,  1 ), Cells(lRow -  1 ,  19 ))
        wbNewBook.Close savechanges:=True
        lFirstRow = lRow
    End If
Next lRow
End Sub