Office: (Office 2013) Tabelle aus meheren Excel-Dateien zusammenführen

Hallo!

Ich beschäftige mich schon seit geraumer Zeit mit einer Problemstellung in VBA und benötige eure Hilfe:

Bin in VBA ein kompletter Neuling
Ich versuche bestimmte Bereiche aus mehreren Excel-Dateien zu kopieren und in eine "Master"-Datei zu kopieren. Hab auch bereits einen Code gefunden der das macht! Nun brauche ich aber noch eine zusätzliche Spalte in der der Dateiname der jeweiligen Datei eingefügt wird...

Der Code den ich verwende lautet wie folgt:

Code:

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, 11).Formula = _
                 "='" & sPfad & "[" & sDatei & "]Tabelle1'!A2"
             Else
                 blnÜberschrift = True
                 .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 11).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

Danke für eure Hilfe!

 

Hi thomas-bacher

Vielleicht hilft dir das:

Setzt voraus, dass alle Datenblätter die gleiche Anzahl Spalten besitzen. Macht Dir dann am jeweils am Ende der Daten einer Datei den Namen hin :)
Im Übrigen musst Du den Codeschnipsel am Ende der "For i = 1 To UBound(vFileToOpen)"-Schlaufe einfügen (aber noch darin)!

Grüsse, Reida

EDIT:
Mir ist gerade in den Sinn gekommen, dass Du den Namen evtl. auf jeder Zeile möchtest, um Filter zu benutzen..