Inhalt von Excel Dateien in einer Tabelle auflisten, zusammenführen

Private Sub AlleTabellenblätterZusammenführen_Click()
Dim vntPfadUndDateiNamen As Variant
Dim strPfadUndDatei As String
Dim lngi As Long
Dim wbkMappe As Workbook
Dim wksTabelle As Worksheet
Dim wbkZiel As Workbook
Set wbkZiel = ThisWorkbook
Dim EndeQuelle As Long
Dim EndeZiel As Long

'Liste in der Zieltabelle leeren  
ActiveSheet.Rows("4:10000").EntireRow.Select  
Selection.ClearContents

'Dateien auswählen, die zusammengeführt werden sollen  
vntPfadUndDateiNamen = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Wählen Sie die Dateien für die Zusammenführung aus!", MultiSelect:=True)  
If VarType(vntPfadUndDateiNamen) = vbBoolean Then
MsgBox "Vorgang wurde abgebrochen!"  
Else

For lngi = LBound(vntPfadUndDateiNamen) To UBound(vntPfadUndDateiNamen)
strPfadUndDatei = vntPfadUndDateiNamen(lngi)
Set wbkMappe = Application.Workbooks.Open(strPfadUndDatei, ReadOnly:=True)

'Kopiere in der Quelldatei alle beschriebenen Zeilen ab Zeile 4  
EndeQuelle = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
ActiveSheet.Rows("4:" & EndeQuelle).EntireRow.Select  
Selection.Copy

'Füge die kopierten Zeilen in die Zieltabelle am Ende ein  
wbkZiel.Activate
EndeZiel = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row + 1
ActiveSheet.Cells(EndeZiel, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.DisplayAlerts = False
wbkMappe.Close False
Next
End If
End Sub