Performance verbessern?

Sub createLists()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim startDate As Date
Dim endDate As Date
Dim dateLooper As Date
Dim currDate As String
'Set date range for existing files
startDate = #1/1/2012#
endDate = #9/12/2014#
'Array, which contains names for new worksheets as strings
Dim tsN(1 To 12) As String
tsN(1) = "AA11"
tsN(2) = "AA22"
tsN(3) = "AA33"
tsN(4) = "AA44"
tsN(5) = "AA55"
tsN(6) = "AA66"
tsN(7) = "BB11"
tsN(8) = "BB22"
tsN(9) = "BB33"
tsN(10) = "BB44"
tsN(11) = "BB55"
tsN(12) = "BB66"
Dim w1 As Workbook
Dim w2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim localPath As String
localPath = ThisWorkbook.path
'Check for folder "Lists", create if non-existend
Dim fso, folderN
Set fso = CreateObject("Scripting.FileSystemObject")
folderN = localPath & "\Lists\"
If fso.FolderExists(folderN) = False Then MkDir folderN
For dateLooper = startDate To endDate
currDate = Format(dateLooper, "yyyy-mm-dd")
'Open / create workbook objects
Set w1 = Workbooks.Open(Filename:=localPath & "\roh\daten" & currDate & ".CSV", Local:=  _
_
_
_
_
True)
Set w2 = Workbooks.Add()
'Array, which contains worksheet-objects which will reference new worksheets
Dim ts(1 To 12) As Worksheet
'Create new file and add/name new worksheets, set references to array ts
For i = 1 To 12
With w2.Sheets.Add()
.Name = tsN(13 - i)
.Activate
End With
If i = 1 Then w2.Worksheets(2).Delete
Set ts(13 - i) = ActiveSheet
Next i
'Copy data:
Set ws1 = w1.Sheets(1)
'Iterate through products and copy corresponding data to seperate sheets in prev.  _
created new file
For i = 1 To 12
Set ws2 = ts(i)
'Filter data for product
ws1.Range("A1:H1").AutoFilter Field:=2, Criteria1:="=" & tsN(i)
ws1.Range("A1:H1").AutoFilter Field:=7, Criteria1:="=ja"
'Select range and copy
Dim lastRow As Long
lastRow = ws1.UsedRange.Rows.Count
ws1.Range("A1:H" & lastRow).Copy ws2.Range("A1:H1")
'Sort copied data
With ws2
.Range("A1").Sort Key1:=.Range("D1"), Order1:=xlAscending, DataOption1:= _
xlSortNormal, Header:=xlYes
End With
ws1.AutoFilterMode = False
Next i
'Save newly created file
w2.SaveAs Filename:=localPath & "\Lists\Lists-" & currDate & ".xls", FileFormat:= _
xlNormal
w2.Close
w1.Close
Next dateLooper
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub