Sub ImportFiles()
Dim sFilename As String
Dim sPath As String, sTable As String, sAddr As String
Dim wbk As Workbook, rng As Range
Dim rngP As Range
Dim lngRow As Long
sPath = ThisWorkbook.Names("Dateipfad").RefersToRange.Value
sPath = sPath & IIf(Right(sPath, 1) = "\", "", "\")
sTable = ThisWorkbook.Names("Registerblatt").RefersToRange.Value
sAddr = ThisWorkbook.Names("StartZelle").RefersToRange.Value & ":" & ThisWorkbook.Names("EndZelle").RefersToRange.Value
sFilename = Dir(sPath & "*.xlsx")
lngRow = 5
Do Until sFilename = ""
Set wbk = Application.Workbooks.Open(sPath & sFilename)
Set rng = wbk.Worksheets(sTable).Range(sAddr)
rng.Copy
ThisWorkbook.Worksheets(1).Cells(lngRow, 2).PasteSpecial xlAll
ThisWorkbook.Activate
ThisWorkbook.Worksheets(1).Activate
Set rngP = Selection
rngP.Columns(1).Offset(ColumnOffset:=-1).Value = sPath & sFilename
lngRow = lngRow + rng.Rows.Count
Application.CutCopyMode = False
wbk.Close False
sFilename = Dir()
VBA.DoEvents
Loop
End Sub