vba-- kopieren einschränken
09.02.2019 11:26:07
Fred
Hallo Excel Profis,
ich habe ein VBA, welches mir aus bestimmten Mappen (Blattnamen sind identisch) jeweils die ersten 9 Spalten eines jeden Blattes, in mein Blatt Zusammenfasung kopiert. In Spalte 10 (J) wird noch eine Bezeichnung (Zuordnung der Ursprungsmappe) eingefügt.
Das Makro läuft einwandfrei, meine Bitte;
Kann mir jemand das VBA dahin ändern, dass anstatt alle Blätter (der aufgerufenen Mappen) nur das Arbeitsblatt mit den Namen T14 (ist in allen Mappen vorhanden) berücksichtigt wird?
Hier das VBA
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
Mit freundlichen Gruß
Fred Neumann