Wie kann ich einzelne Zellen aus mehreren Exceldateien in einer Exceldatei zusammenfassen?

Option Explicit
Option Compare Text

Const Folder = "C:\Wochenbericht\Team"  

Const StartZeile = 7

Sub GetWeekData()
    Dim Wkb As Workbook, Fso As Object, File As Object, Zeile As Long
    
    Set Fso = CreateObject("Scripting.FileSystemObject")    'Dateisystem-Operationen  
    
    Range(Cells(StartZeile, "A"), Cells(Rows.Count, "E")).ClearContents 'Inhalte ab Startzeile löschen  
    
    Zeile = StartZeile
    
    With Application
        .ScreenUpdating = False     'Bildschirmaktualisierung aus  
        .AskToUpdateLinks = False   'Verknüpfung (Name aus Übersicht) ohne Abfrage aktualisieren  
        .DisplayAlerts = False      'Fehlermeldung "Verknüpfung kann nicht..." unterdrücken  
    End With
    
    For Each File In Fso.GetFolder(Folder).Files  'Alle _KW#.xls-Dateien einlesen und eintragen  
        If Fso.GetExtensionName(File.Name) Like "xls" And Fso.GetBaseName(File.Name) Like "*_KW#*" Then  
            Set Wkb = GetObject(File.Path)
            With Wkb.Sheets(1)  'Werte mit Zahlenformat  
                .Range("C3").Copy:   Cells(Zeile, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats  
                .Range("C5").Copy:   Cells(Zeile, "B").PasteSpecial Paste:=xlPasteValuesAndNumberFormats  
                .Range("E56").Copy:  Cells(Zeile, "C").PasteSpecial Paste:=xlPasteValuesAndNumberFormats  
                .Range("E55").Copy:  Cells(Zeile, "D").PasteSpecial Paste:=xlPasteValuesAndNumberFormats  
                .Range("I55").Copy:  Cells(Zeile, "E").PasteSpecial Paste:=xlPasteValuesAndNumberFormats  
                
                'Werte ohne Zahlenformat  
                'Cells(Zeile, "A") = .Range("C3")  
                'Cells(Zeile, "B") = .Range("C5")  
                'Cells(Zeile, "C") = .Range("E56")  
                'Cells(Zeile, "D") = .Range("E55")  
                'Cells(Zeile, "E") = .Range("I55")  
            End With
            Wkb.Close False:  Zeile = Zeile + 1
        End If
    Next
    
    Range(Cells(StartZeile, "A"), Cells(Zeile, "E")).Sort _  
        Key1:=Cells(StartZeile, "B"), Key2:=Cells(StartZeile, "A"), Header:=xlNo, Orientation:=xlTopToBottom  
    
    With Application
        .DisplayAlerts = True
        .AskToUpdateLinks = True
        .ScreenUpdating = True
    End With
    
    ThisWorkbook.Save:  MsgBox "Fertig", vbInformation, "Wochenberichte einlesen..."  
End Sub