
Application.ScreenUpdating = False
For i = 2 To List1.Cells(65000, 12).End(xlUp).Row
If List1.Cells(i, 12) <> List1.Cells(i - 1, 12) Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = List1.Cells(i, 12)
End If
If Worksheets.Count > 1 And IsEmpty(Worksheets(Worksheets.Count).Cells(1, 1)) = True Then
j = List1.Range("L:L").Find(List1.Cells(i, 12)).Row
Do Until List1.Cells(j, 12) <> List1.Cells(i, 12)
j = j + 1
Loop
List1.Select
List1.Range("a1:o1").Copy
Worksheets(Worksheets.Count).Select
Worksheets(Worksheets.Count).Range("a1").Select: ActiveSheet.Paste
List1.Select
List1.Range(Cells(List1.Range("L:L").Find(List1.Cells(i, 12)).Row, 1), Cells(j - 1, 15)).Copy
Worksheets(Worksheets.Count).Select
Worksheets(Worksheets.Count).Cells(Worksheets(Worksheets.Count).Cells(65000, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlValue
ActiveSheet.PageSetup.PrintArea = ActiveSheet.UsedRange.Address
ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous
ActiveSheet.UsedRange.BorderAround Weight:=xlMedium
End If
Next i
Application.ScreenUpdating = True
End Sub