VBA - Informationen aus mehreren Dateien auslesen

Sub Zusammenfassen()

Const sSourcePath = "D:\Datensammlung" 'Ordner der Fragebogendateien - bitte anpassen  

Set wbGes = ActiveWorkbook 'aktuelle Mappe und ...  
Set wsZiel = ActiveWorkbook.ActiveSheet '... aktuelle Tabelle zwischenspeichern  
Set fso = CreateObject("Scripting.FileSystemObject")  

Z = 11 'ab Zeile 11 in der Sammeltabelle eintragen  
sNamen = "#" 'Variable zum Sammeln der Namen vorbelegen  

Application.ScreenUpdating = False 'während der folgenden Aktionen Excel-Bildschirm "einfrieren"; diese Zeile kann auch auskommentiert / entfernt werden  
For Each oFile In fso.GetFolder(sSourcePath).Files 'alle Dateien des Fragebogenordners durchgehen  
    If LCase(fso.GetExtensionName(oFile.Name)) = "xls" Then 'nur .xls-Dateien bearbeiten; falls "xlsx" bitte anpassen; nur Kleinbuchstaben verwenden  
        Set wbQuellDatei = Application.Workbooks.Open(oFile.Path) 'Fragebogendatei öffnen  
        With ActiveWorkbook.Worksheets(1) 'Daten aus der ersten Tabelle der Fragebogendatei entnehmen  
            If .Range("E2").Value <> "" Then 'E2 nicht leer?  
                N = .Range("B2").Value 'Namen auslesen und ...  
                If InStr(sNamen, "#" & N & "#") = 0 Then '... prüfen, ob bereits verarbeitet  
                    .Range("B2:B10").Copy 'Daten kopieren und ...  
                    wsZiel.Cells(Z, "A").PasteSpecial Paste:=xlPasteAll, Transpose:=True '... einfügen (dabei die Spalte als Zeile behandeln)  
                    sNamen = sNamen & N & "#" 'Namen aus dem eben kopierten Datensatzes in die Liste aufnehmen  
                    Z = Z + 1 'Zeilennummer der Zieltabelle für das nächste Einfügen erhöhen  
                Else 'Name wurde bereits eingelesen - was nun?  
                    'Aktion, falls Name bereits eingelesen wurde  
                End If
            End If
        End With
        wbQuellDatei.Close 'Fragebogendatei schließen  
    End If
Next
Application.ScreenUpdating = True 'Excel-Bildschirmanzeige wieder "auftauen" ;-)  
wsZiel.Activate 'zur Sicherheit Zieltabelle aktivieren  
wbGes.Save 'Sammeldatei speichern  
MsgBox "Fertig."  
End Sub

Sub Zusammenfassen()

Const sSourcePath = "D:\Datensammlung"  

Set wbGes = ActiveWorkbook
Set Ziel = ActiveWorkbook.ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")  

AbZeile = 11 '(ab Zeile 11 in der Sammeltabelle eintragen)  
Application.ScreenUpdating = False
For Each oFile In fso.GetFolder(sSourcePath).Files
    If LCase(fso.GetExtensionName(oFile.Name)) = "xls" Then 'nur .xls-Dateien bearbeiten  
        Set wbQuellDatei = Application.Workbooks.Open(oFile.Path)
        With ActiveWorkbook.Worksheets(1)
            If .Range("E2").Value <> "" Then 'E2 nicht leer?  
                N = LCase(.Range("B2").Value) 'Namen in Kleinbuchstaben auslesen und ...  
                Z = AbZeile '... ab der ersten Dateienzeile ...  
                '... in Spalte A suchen; falls nicht gefunden, erste Zeile ohne Eintrag in Spalte A verwenden  
                Do Until Ziel.Cells(Z, "A").Value = "" Or LCase(Ziel.Cells(Z, "A").Value) = N   
                    Z = Z + 1 'nächste Zeile untersuchen  
                Loop
                .Range("B2:B10").Copy 'kopieren und ...  
                Ziel.Cells(Z, "A").PasteSpecial Paste:=xlPasteAll, Transpose:=True '... einfügen (dabei die Spalte als Zeile behandeln)  
            End If
        End With
        wbQuellDatei.Close
    End If
Next 'Datei  
Application.ScreenUpdating = True
Ziel.Activate
'Gesamt-Datei speichern  
wbGes.Save
MsgBox "Fertig."  
End Sub