Bereich aus Dateien eines Verzeichnisses auslesen

Sub start()
Dim arr As Variant
Dim iCounter As Integer, iRow As Integer
Dim sPath As String
Application.ScreenUpdating = False
sPath = GetDirectory( _
"Bitte Pfad der Quelldateien auswählen:")
If sPath = "" Then Exit Sub
arr = FileArray(sPath, "*.xlsx")
iRow = 5
On Error Resume Next
For iCounter = 1 To UBound(arr)
Workbooks.Open sPath & "\" & arr(iCounter)
Application.ScreenUpdating = False
Range("E10:F10").Copy _
ThisWorkbook.Worksheets("Tabelle1").Cells(iRow, 2)
ActiveWorkbook.Close savechanges:=False
iRow = iRow + 1
Next iCounter
Application.ScreenUpdating = True
End Sub

Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Declare 

Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetDirectory(Optional Msg As String) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function


Function FileArray(strPath As String, strPattern As String)
Dim arrDateien()
Dim intCounter As Integer
Dim strDatei As String
If Right(strPath, 1)  "\" Then strPath = strPath & "\"
strDatei = Dir(strPath & strPattern)
Do While strDatei  ""
intCounter = intCounter + 1
ReDim Preserve arrDateien(1 To intCounter)
arrDateien(intCounter) = strDatei
strDatei = Dir()
Loop
FileArray = arrDateien
End Function



Hat jemend eine Idee und kann helfen?

Vielen Dank. Grüße