Sub GetData()

Set oMe = ThisWorkbook.ActiveSheet 'ZielDatei/-Tabelle (= die aktuelle Tabelle der aktuellen Datei)

Const sDateiPfad As String = "T:\20_Laboratory\TR\01_SK\01_P\Aufträge\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende

sZelle1 = "B5" 'NOx 1. Temp.
sZelle2 = "B4" 'NOx 1. K-Wert.
sZelle3 = "C5" 'NOx 2. Temp.
sZelle4 = "C4" 'Nox 2. K-Wert.
sZelle5 = "D5" 'SOx 1. Temp.
sZelle6 = "D4" 'SOx 1. ETA
sZelle7 = "E5" 'SOx 2. Temp.
sZelle8 = "E4" 'SOx 2. ETA
sZelle9 = "F4" 'Porenvolumen.
sZelle10 = "G4" 'Abrieb
sZelle11 = "H4" 'BET
sZelle12 = "I4" 'Druckprüfung long.
sZelle13 = "J4" 'Druckprüfung trans.
sZelle14 = "K4" 'Vanadium ist
sZelle15 = "G2" 'Vanadium soll
sZelle16 = "A1" 'Auftragsnummer+Name
sZelle17 = "K1" 'Jahr
iZeile = 2 'ab Zeile 2 in Zieltabelle eintragen
iSpalte = 1 'ab Spalte A in Zieltabelle eintragen

Set oFS = CreateObject("Scripting.FileSystemObject")


For Each oDatei In oFS.GetFolder(sDateiPfad).Files


    sWbName = oDatei.Name

    If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then


        Workbooks.Open (sDateiPfad & sWbName)
        Set Wsh = Workbooks(sWbName).Sheets("Übersicht")
        
        With oMe.Cells(iZeile, iSpalte)
           .Offset(0, 0).Value = Wsh.Range(sZelle1).Value
           .Offset(0, 1).Value = Wsh.Range(sZelle2).Value
           .Offset(0, 2).Value = Wsh.Range(sZelle3).Value
           .Offset(0, 3).Value = Wsh.Range(sZelle4).Value
           .Offset(0, 4).Value = Wsh.Range(sZelle5).Value
           .Offset(0, 5).Value = Wsh.Range(sZelle6).Value
           .Offset(0, 6).Value = Wsh.Range(sZelle7).Value
           .Offset(0, 7).Value = Wsh.Range(sZelle8).Value
           .Offset(0, 8).Value = Wsh.Range(sZelle9).Value
           .Offset(0, 9).Value = Wsh.Range(sZelle10).Value
           .Offset(0, 10).Value = Wsh.Range(sZelle11).Value
           .Offset(0, 11).Value = Wsh.Range(sZelle12).Value
           .Offset(0, 12).Value = Wsh.Range(sZelle13).Value
           .Offset(0, 13).Value = Wsh.Range(sZelle14).Value
           .Offset(0, 14).Value = Wsh.Range(sZelle15).Value
           .Offset(0, 15).Value = Wsh.Range(sZelle16).Value
           .Offset(0, 16).Value = Wsh.Range(sZelle17).Value
           oMe.Hyperlinks.Add Anchor:=oMe.Cells(iZeile, iSpalte + 17), Address:=sDateiPfad & sWbName, TextToDisplay:="zum Auftrag"
          End With
        
        Workbooks(sWbName).Saved = True


        Workbooks(sWbName).Close


        iZeile = iZeile + 1


    End If

Next


End Sub