Excel 2007 - Werte aus mehreren Dateien per Makro auslesen und in Übersichtstabelle einfügen

Option Explicit
Option Compare Text

Const sFolder = "C:\Prüfberichte"              'Datei-Pfad Berichte  
Const sFileName = "*2011-30*"                   'Datei-Name enthält  
Const sFileType = "xlsm"                       'Datei-Erweiterung  

Const iStartZeile = 7       'Ab Zeile ?  
Const sFilter = "=???.*"    'Kostennummer = 3 Zeichen + Punkt und keine/weitere Zeichen  

Const Msg1 = "Alle Daten eingelesen!"  
Const Err1 = "Kostennummer (%1) in der Übersicht nicht gefunden!"  

Sub GetBKPData()
    Dim Wkb As Workbook, oFso As Object, oFile As Object, oFound As Range
    Dim aQCells As Variant, iEndZeile As Long, iZeile As Long, i As Integer

    Set oFso = CreateObject("Scripting.FileSystemObject") 'Dateisystem-Operationen  

    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

   'Copy-Zell-Adressen in Array splitten  
    aQCells = Split("D7,D8,H29,H33,F46,H41,H42,H4", ",")  'Entspricht Spalte B, C, D, E, F, G, H, I  
    
    Call CleanUp(UBound(aQCells))
    
    For Each oFile In oFso.GetFolder(sFolder).Files
        If oFso.GetExtensionName(oFile.Name) Like sFileType And oFso.GetBaseName(oFile.Name) Like sFileName Then
            Set Wkb = GetObject(oFile.Path) '2011-30 kommt in der *.xlsm immer vor, da Projektnummer  
            With Wkb.Sheets(1) 'Werte mit Zahlenformat  
                Set oFound = Range("A:A").Find(.Range("H7").Value, LookIn:=xlValues, LookAt:=xlWhole)  
                
                If oFound Is Nothing Then
                    MsgBox Replace(Err1, "%1", .Range("H7").Value), vbExclamation, "Fehler . . ."  
                Else
                    iZeile = oFound.Row
            
                    If IsEmpty(Cells(iZeile, "D")) Then 'Test Auftrags-Volumen Leer  
                       'Zellen kopieren und einfügen  
                        For i = 0 To UBound(aQCells)
                           .Range(Trim(aQCells(i))).Copy
                            Cells(iZeile, "B").Offset(0, i).PasteSpecial Paste:=xlPasteValuesAndNumberFormats  
                        Next
                    Else
                       'Spalte D/E aufaddieren  
                        Cells(iZeile, "D").Value = Cells(iZeile, "D").Value + .Range("H29").Value  
                        Cells(iZeile, "E").Value = Cells(iZeile, "E").Value + .Range("H33").Value  
                    End If
                End If
            End With
            Wkb.Close False
        End If
    Next

   'Sort weggelassen, scheint mir überflüssig zu sein  

    With Application
        .DisplayAlerts = True
        .AskToUpdateLinks = True
        .ScreenUpdating = True
    End With

    ThisWorkbook.Save: MsgBox Msg1, vbInformation, "Datenimport . . ."  
 End Sub

'Mit dieser Funktion werden die Zellinhalte nur in den Zeilen mit Kostennummern (ab Spalte B)  
'entsprechend dem Such-Kriterium 3 Zeichen + '.' + keine/weitere Zeichen (???.*) gelöscht  

Private Sub CleanUp(ByVal iColOffset)
    Dim iEndZeile As Long
    
    ActiveSheet.AutoFilterMode = False
    
    iEndZeile = Cells(Rows.Count, "A").End(xlUp).Row  
    
    With Range(Cells(iStartZeile - 1, "A"), Cells(iEndZeile, "A"))  
        .AutoFilter Field:=1, Criteria1:=sFilter, Operator:=xlAnd, VisibleDropDown:=False
    End With

    Range(Cells(iStartZeile, "B"), Cells(iEndZeile, "B").Offset(0, iColOffset)).Cells.Clear  

    ActiveSheet.AutoFilterMode = False
End Sub