Option Explicit
Sub GetData()
Dim oMe As Worksheet, iZeile As Long, oDatei As Object
Dim oFS As Object, wbQuelle As Workbook
Set oMe = ThisWorkbook.ActiveSheet
Const sDateiPfad As String = "D:\\Temp\"
iZeile = 19
Application.ScreenUpdating = False
Set oFS = CreateObject("Scripting.FileSystemObject")
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
If Right(LCase(oDatei.Name), 4) = "xlsx" Then
Set wbQuelle = Workbooks.Open(sDateiPfad & oDatei.Name)
With wbQuelle.ActiveSheet
oMe.Cells(iZeile, 1) = .Range("B4")
oMe.Cells(iZeile, 2) = .Range("B12")
oMe.Cells(iZeile, 3) = .Range("B13")
oMe.Cells(iZeile, 4) = .Range("B14")
oMe.Cells(iZeile, 5) = .Range("B15")
oMe.Cells(iZeile, 6) = .Range("B16")
oMe.Cells(iZeile, 7) = .Range("B21")
oMe.Cells(iZeile, 8) = .Range("B24")
oMe.Cells(iZeile, 9) = .Range("B25")
oMe.Cells(iZeile, 10) = .Range("B32")
oMe.Cells(iZeile, 11) = .Range("B23")
oMe.Cells(iZeile, 12) = .Range("G26")
oMe.Cells(iZeile, 13) = .Range("H45")
oMe.Cells(iZeile, 14) = .Range("B26")
oMe.Cells(iZeile, 15) = .Range("B27")
oMe.Cells(iZeile, 16) = .Range("G23")
oMe.Hyperlinks.Add Anchor:=oMe.Cells(iZeile, 28), Address:=sDateiPfad _
& wbQuelle.Name, TextToDisplay:=wbQuelle.Name
wbQuelle.Close False
iZeile = iZeile + 1
End With
End If
Next
Set oMe = Nothing: Set wbQuelle = Nothing
End Sub