W wolnej chwili wyklikałem na klawiaturze kilka linijek. Wydaje mi się, że wygodniej będzie Ci przystosować mój krótki kod. Sub Podziel() Dim a As String, a1 As Worksheet Set a1 = Sheets("Arkusz1") ow = Cells(Rows.Count, "D").End(xlUp).Row f = True Sheets("Arkusz1").Select For x = 5 To ow a = a1.Cells(x, 16) If f Then y = x f = False End If If a1.Cells(x + 1, 16) <> a1.Cells(x, 16) Then f = True If Not IstniejeArkusz(a) Then Sheets.Add.Name = a a1.Select Range(Cells(y, 1), Cells(x, 15)).Select Selection.Copy Sheets(a).Select nw = Cells(Rows.Count, "A").End(xlUp).Row + 1 Cells(nw, 1).Select ActiveSheet.Paste End If Next End Sub Function IstniejeArkusz(Nazwa As String) As Boolean Dim ark As Worksheet IstniejeArkusz = False For Each ark In ThisWorkbook.Worksheets If ark.Name = Nazwa Then IstniejeArkusz = True Next ark End Function Dodałem załącznik.