Tabellendaten in neuer Datei zusammenfassen

Sub Konsolidierung()
'Variablen Definitionen
Dim MySheet As Worksheet ' aktuelles Arbeitsblatt der offenen Ziel-Datei-hier werden die Daten reingeschrieben
Dim strPath As String ' Dateipfad zum Auslesen der Dateien
Dim strFile As String ' Quelldatei
Dim wkbInput, meins As Workbook ' Quell-Arbeitsmappe
Dim wksInput As Worksheet ' Quell-Registerblatt
Dim lngTargetRow As Long ' Zeilenzähler für die Bewertungsinformationen
Dim lRow As Long ' Schleifenzähler
Dim lCol As Long ' Schleifenzähler
Dim delta As Integer
Application.DisplayAlerts = False
delta = 0 'Zaehler um in die nächste Zeile zu schreiben
'Merkt sich die Daten der Zieldatei
Set MySheet = ActiveSheet
Set meins = ActiveWorkbook
strPath = ActiveWorkbook.Path
' Verzeichnis durchgehen und alle Dateien auslesen
strFile = Dir(strPath & "\*.xls")
Do While strFile <> "" ' Schleife beginnen
If strFile = ActiveWorkbook.Name Then
' Zieldatei natürlich übergehen
Else
' Quelldatei öffnen
' und 1. Registerblatt auswählen
Set wkbInput = Application.Workbooks.Open(strPath & "\" & strFile)
Set wksInput = wkbInput.Worksheets("Quellregisterblatt") 'Hier ist das Quell-Sheet zu definieren zwischen die Hochkommata die Bezeichnung des sheets eingeben'
' Daten auslesen und in Auswertung kopieren'
wksInput.Activate 'Auswahl Quell-Sheet
wksInput.Cells(1, 1).Select 'Select der Quell-Zelle
Print Selection.Copy 'Kopieren
meins.Activate 'Aktivieren des-Ziel-Workbook
MySheet.Activate 'Aktivieren des Ziel-Sheet
MySheet.Cells(2 + delta, 1).Select 'Auswahl Ziel-Zellen (zeilen werden durch Delta hochgezählt)
'Einfügen des Wertes
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
delta = delta + 1 'Nächste Zeile
' Bis hier CODE zum Auslesen
' Datei schließen
wkbInput.Close
Set wkbInput = Nothing
End If
strFile = Dir ' Nächsten Eintrag abrufen
Loop
MsgBox "Ich habe Fertig!"
End Sub