Hallo zusammen,

ich bin VBA Neuling und komme aktuell nicht weiter. Ziel ist es, Excel Daten aus >120 Dateien auszulesen und in ein Tabellenblatt zusammen zu führen. Das funktioniert soweit auch. Nun bräuchte ich aber eine zusätzliche Spalte in die der Pfad der Ursprungstabelle geschrieben wird, sodas ich auf einen Blick seh aus welchen Dateien meine Daten kommen. Aktuell sieht das ganze etwas wild aus...

Ich hoffe ihr könnt mir helfen...

VIelen lieben Dank vorab!

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
    Dim AppShell        As Object
    Dim BrowseDir       As Variant
    Dim pfad            As String
   
        With ActiveSheet
        If .FilterMode Then .ShowAllData
     End With
    
    

       Range("1:1048576").ClearContents
   On Error Resume Next
 
    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 Tabelle4.Range("A2")
             .Formula = "=LOOKUP(2,1/('" & sPfad & "[" & sDatei & "]Tabelle4'!$H:$H<>""""),ROW('" & sPfad & "\[" & sDatei & "]Tabelle4'!$H:$H))"
             lngLZ = .Value - 8
             
End With
        
        
               

               With Tabelle4
               If blnÜberschrift Then
                .Cells(.Rows.Count, 2).End(xlUp).Offset(1).Resize(lngLZ - 1, 11).Formula = _
                "= IF('" & sPfad & "[" & sDatei & "]Tabelle4'!B10="""","""",'" & sPfad & "[" & sDatei & "]Tabelle4'!B10)"
               
            Else
                blnÜberschrift = True
                
                .Cells(.Rows.Count, 2).End(xlUp).Offset(1).Resize(lngLZ, 11).Formula = _
                "=IF('" & sPfad & "[" & sDatei & "]Tabelle4'!B9="""","""",'" & sPfad & "[" & sDatei & "]Tabelle4'!B9)"

End If
End With
        With Range("A1").Select
            ActiveCell.FormulaR1C1 = Application.ActiveWorkbook.Path & _
            "\" & Application.ActiveWorkbook.Name
         End With
         
       

         
      
         Call StatusBalken(Int((i / UBound(vFileToOpen)) * 100))
   
    Next
   
With Tabelle4.UsedRange
        .Copy
        .PasteSpecial xlPasteValues
        .Rows(5).Delete
     
      
     
       
    End With
 MsgBox "Juhu, du hast es geschafft   :-)"
   
ENDE:
    Application.EnableEvents = True
    Application.Calculation = iCalc
    Application.ScreenUpdating = True
    If Err Then MsgBox Err.Description, , "Fehler: " & Err
End Sub