vba-- kopieren einschränken

Sub Import()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Worksheets("Basis").Range("A2:J500").EntireRow.Delete
Dim wksZ As Worksheet, wksQ As Worksheet, wkbQ As Workbook, wksQArray, Wb As Long
Const strWkbQName As String = "S_14,S_15,S_16,S_17,S_18,S_19"
Const strWkbQ As String = "a1.xlsx,a2.xlsx,a3.a4.xlsx,a5.xlsx,a6.xlsx"
Application.ScreenUpdating = False
Set wksZ = ThisWorkbook.Sheets("Zusammenfassung")
On Error Resume Next
For Wb = LBound(Split(strWkbQ, ",")) To UBound(Split(strWkbQ, ","))
On Error Resume Next
Set wkbQ = Workbooks(Split(strWkbQ, ",")(Wb))
If wkbQ Is Nothing Then
Set wkbQ = Workbooks.Open(ThisWorkbook.Path & "\Daten\" & Split(strWkbQ, ",")(Wb))
End If
For Each wksQ In wkbQ.Worksheets
wksQArray = wksQ.Cells(1, 1).CurrentRegion.Offset(1).Resize(, 9).Value
wksZ.Cells(wksZ.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(wksQArray, 1), UBound( _
wksQArray, 2)) = wksQArray
wksZ.Cells(wksZ.Rows.Count, "J").End(xlUp).Offset(1).Resize(UBound(wksQArray, 1) - 1) =  _
Split(strWkbQName, ",")(Wb)
Next
wkbQ.Close False 'QuellWB ohne zu speichern schließen
Set wkbQ = Nothing
Next Wb
Application.CutCopyMode = False
' daten absteigend sortieren
Sheets("Zusammenfassung").Activate
Selection.AutoFilter
ActiveWorkbook.Worksheets("Basis").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Basis").AutoFilter.Sort.SortFields.Add Key:= _
Range("B1:B50000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("Basis").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Selection.AutoFilter
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
Sheets("Inhalt").Activate
Application.ScreenUpdating = True
End Sub