Hallo,

Ich habe ein Problem und bin mir sicher, dass ihr mir weiterhelfen könnt. Ich muss aus mehreren Dateien, jeweils ein Tabellenblatt kopieren bzw. mehrere Dateien konsolidieren. 

Ein Grundgerüst meines Makros/VBA besteht schon, bloß hat sich nun der Aufbau der Dateien geändert. 
Der Makro ist ausgelegt, dass er vom ersten Arbeitsblatt die Überschrift kopiert (Zeile A1:AD1) und dann von den anderen Dateien jeweils die Tabellen ohne Überschrift (Also A2:AD..)  unter einander kopiert.
Der Aufbau der Dateien hat sich nun soweit geändert, dass die Überschrift in der Reihe C10:AG10 stehen und die Tabelle jeweils darunter.

Des Weiteren wurden Zeilen eingefügt, die nicht in der konsolidierten Datei mitaufgenommen werden sollen!

Kann mir da bitte jemand helfen? Vielen Dank

Mein Makro

Sub Zusammenführen() 
    Dim i               As Long 
    Dim sPfad           As String 
    Dim sDatei          As String 
    Dim vFileToOpen     As Variant 
    Dim lngLZ           As Long 
    Dim blnÜberschrift  As Boolean 
    Dim iCalc           As Integer 
    
    
    vFileToOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True) 
    If Not IsArray(vFileToOpen) Then Exit Sub 
    
        
    iCalc = Application.Calculation 

    On Error GoTo ENDE: 
    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 
    Application.EnableEvents = False 
    
    
    For i = 1 To UBound(vFileToOpen) 
        sDatei = Dir(vFileToOpen(i)) 
        sPfad = Left(vFileToOpen(i), InStr(vFileToOpen(i), sDatei) - 1) 
    
        With Tabelle1.Range("A1") 
            .Formula = "=LOOKUP(2,1/('" & sPfad & "[" & sDatei & "]Tabelle1'!$A:$A<>""""),ROW('" & sPfad & "\[" & sDatei & "]Tabelle1'!$A:$A))" 
            lngLZ = .Value 
        End With 
        
        With Tabelle1 
            If blnÜberschrift Then 
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ - 1, 5).Formula = _ 
                "='" & sPfad & "[" & sDatei & "]Tabelle1'!A2" 
            Else 
                blnÜberschrift = True 
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 5).Formula = _ 
                "='" & sPfad & "[" & sDatei & "]Tabelle1'!A1" 
            End If 
        End With 
        
        Call StatusBalken(Int((i / UBound(vFileToOpen)) * 100)) 
    Next 
    
    With Tabelle1.UsedRange 
        .Copy 
        .PasteSpecial xlPasteValues 
        .Rows(1).Delete 
    End With 
    
ENDE: 
    Application.EnableEvents = True 
    Application.Calculation = iCalc 
    Application.ScreenUpdating = True 
    If Err Then MsgBox Err.Description, , "Fehler: " & Err 
End Sub 

Sub StatusBalken(ProzentSatz) ''ProzentSatz = Int((i / 10000) * 100) 
    Dim Mess, Z, Rest 
    Static oldStatusBar As Integer 
    Static blnInit As Boolean 

    If Not blnInit Then 
        oldStatusBar = Application.DisplayStatusBar 
        Application.DisplayStatusBar = True 
    End If 
    
    Mess = "" 
    For Z = 1 To ProzentSatz 
        Mess = Mess & ChrW(Val("&H25A0")) 
    Next Z 
    Rest = 100 - ProzentSatz 
    For Z = 1 To Rest 
        Mess = Mess & ChrW(Val("&H25A1")) 
    Next Z 
    Application.StatusBar = Mess & " " & ProzentSatz & "%" 
    
    If Rest <= 0 Then 
        Application.StatusBar = False 
        Application.DisplayStatusBar = oldStatusBar 
    End If 
End Sub