Zusammenführen von Daten mit Dateiname

Option Explicit
'Quelle: https://www.herber.de/forum
'Modifiziert: fcs 2017-10-27
Public glngFile As Long, garrFiles() As String
Sub ListFilesInFolder(ByVal SourceFolderName As String, _
Optional DateiFormat As String = "*.*", _
Optional IncludeSubfolders As Boolean = False)
'Makro erstellt entsprechend den Parametern ein Daten-Array mit den Namen _
der Dateien im Verzeichnis, ggf. inkl. Unterverzeichnissen
'1.Parameter Ordner, wo soll gesucht werden?
'2.Parameter Dateifilter, ggf. * als Platzhalter verwenden
'3.Parameter mit Unterordner = True, False ist ohne
'Erstellt gemäß Suchkriterien ein Array mit den Dateinamen - inklusive Pfad
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Dim Status As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein
For Each FileItem In SourceFolder.Files
If LCase(FileItem.Name) Like LCase(DateiFormat) Then
glngFile = glngFile + 1
ReDim Preserve garrFiles(1 To glngFile)
'Pfad\Dateiname
garrFiles(glngFile) = FileItem.Path
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, DateiFormat, IncludeSubfolders
Next SubFolder
End If
Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub
Sub Import()
' Alle *.xls* eines Verzeichnisses in 1 (das aktuelle) Sheet importieren
Dim FullName As String
Dim wbkZiel As Workbook
Dim z As Integer  'Zähler für Durchläufe
Dim lngFile As Long
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.AskToUpdateLinks = False
.DisplayAlerts = False
.EnableEvents = False
End With
Const Pfad = "C:\Test\" '*** ANPASSEN ***
Const Extension = "*.xls*"       '*** ANPASSEN ***
Const MitKopfzeile = False        '*** ANPASSEN ***
'Dateiliste zurücksetzen
glngFile = 0
Erase garrFiles
'Dateiliste erstellen
Call ListFilesInFolder(SourceFolderName:=Pfad, _
DateiFormat:=Extension, _
IncludeSubfolders:=True)
If glngFile = 0 Then
MsgBox "Keine Excel-Dateien im Verzeichnis """ & Pfad & """ gefunden!"
goto ErrorHandler
End If
'Prüfung, ob Ziel-Sheet leer ist
If WorksheetFunction.CountA(Cells) > 0 Then
If MsgBox("Das Tabellenblatt ist nicht leer," & vbCrLf _
& "sollen die Daten gelöscht werden?", vbCritical + vbYesNo, _
"Warn-Hinweis") = vbYes Then
Cells.Delete
Else
z = 1
End If
End If
'Dateiliste abarbeiten
For lngFile = 1 To glngFile
FullName = garrFiles(lngFile)
Call CopyData(FullName, MitKopfzeile, z)
z = z + 1
Next
'Dateiliste zurücksetzen
glngFile = 0
Erase garrFiles
ErrorHandler:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.AskToUpdateLinks = True
.DisplayAlerts = True
.EnableEvents = True
End With
Dim intRow As Integer, intLastRow As Integer
intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
For intRow = intLastRow To 1 Step -1
If Application.CountA(Rows(intRow)) = 0 Then
intLastRow = intLastRow - 1
Else
Exit For
End If
Next intRow
For intRow = intLastRow To 1 Step -1
If IsEmpty(Cells(intRow, 1)) Then
Rows(intRow).Delete
End If
Next intRow
End Sub