Automat. Zusammenfassen von über 1500 Tabellen

 Name 	 Vorname 	 Geb.datum 	 DatumLabor 	 AP37 	 BAS 	 ...

Sub zfs()

Dim oMe As Object, iZielZeile As Integer, iZielSpalte As Integer, iQuellZeile As Integer, iQuellSpalte As Integer
Dim aID(), sID As String, d As Object, iSp As Integer
Dim Anteile() As String, sZuname As String, sVorname As String, sGebDat As String
Dim i As Integer, sWbName As String, vWert As Variant
Dim oFS As Object, oDatei As Object

Set oMe = ThisWorkbook.Worksheets("Tabelle1") 'Zieltabelle (in der gerade geöffneten Datei)  
iZielZeile = 2 'ab dieser Zeile Ergebnisse in die Zieltabelle eintragen  
Const iZielAbSpalte As Integer = 5 'ab dieser Spalte werden ID (Überschrift) und zugehörige Messwerte eingetragen  

Const iQuelleAbZeile As Integer = 2 'ab dieser Zeile ID in Spalte A  
Const iQuelleAbSpalte As Integer = 5 'ab dieser Spalte Datumseinträge bzw Messwerte in der jeweiligen Quelltabelle  
Const sDateiPfad As String = "E:\Labor\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende  

oMe.Cells.Clear 'gesamte Tabelle löschen  
oMe.Range("A1:D1").Value = Array("Name", "Vorname", "Geb.datum", "DatumLabor") 'Überschrift der ersten 4 Spalten  
aID = Array("AP37", "BAS", "BAS-A", "BILIG", "BZ", "CA", "CHOL", "CRP", "EIW", "HB", "HBA1C") 'benötigte ID hier festlegen  

Set d = CreateObject("Scripting.Dictionary")  
For i = 0 To UBound(aID) 'alle ID durchgehen  
    iZielSpalte = iZielAbSpalte + i 'Spaltennummer ermitteln  
    oMe.Cells(1, iZielSpalte).Value = aID(i) 'Spaltenüberschrift eintragen  
    d.Add UCase(aID(i)), iZielSpalte 'für Vergleich in Großbuchstaben umwandeln und in "Dictionary" einfügen  
Next

Set oFS = CreateObject("Scripting.FileSystemObject")  
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
    sWbName = oDatei.Name
    Anteile = Split(sWbName, "_")  
    sZuname = Anteile(0)
    sVorname = Anteile(1)
    sGebDat = Left(Anteile(2), InStr(Anteile(2), ".xls") - 1)  

    Workbooks.Open (oDatei.Path)
    With Worksheets(2) 'immer 2. Tabelle - falls immer "Tabelle2", dann: Worksheets("Tabelle2")  
        iQuellSpalte = iQuelleAbSpalte
        Do While .Cells(1, iQuellSpalte) <> "" 'alle Datumsspalten bearbeiten  
            oMe.Cells(iZielZeile, 1).Value = sZuname
            oMe.Cells(iZielZeile, 2).Value = sVorname
            oMe.Cells(iZielZeile, 3).Value = sGebDat
            oMe.Cells(iZielZeile, 4).Value = .Cells(1, iQuellSpalte) 'Datum übertragen  
            iQuellZeile = iQuelleAbZeile
            Do While .Cells(iQuellZeile, 1) <> "" 'alle Einträge in Spalte A durchgehen  
                sID = Trim(UCase(.Cells(iQuellZeile, 1))) 'ID auslesen und (für Vergleich) in Großbuchstaben umwandeln  
                If d.Exists(sID) Then 'ID bekannt?  
                    iZielSpalte = d.Item(sID) 'dann zugehörige Spaltennummer ermitteln  
                    vWert = .Cells(iQuellZeile, iQuellSpalte).Value ' Messwert auslesen  
                    oMe.Cells(iZielZeile, iZielSpalte).Value = vWert 'und in aktuelle Zielzelle eintragen  
                End If
                iQuellZeile = iQuellZeile + 1 'nächste Datenzeile  
            Loop
            iQuellSpalte = iQuellSpalte + 1 'nächste Datumsspalte  
            iZielZeile = iZielZeile + 1 'nächste Zeile der Zieltabelle  
        Loop
    End With
    Workbooks(sWbName).Saved = True
    Workbooks(sWbName).Close
Next
End Sub