Ich hatte bei folgendem Thread bereits Hilfe erhalten und würde dieses Makro gern noch erweitern.
https://www.herber.de/cgi-bin/callthread.pl?index=1588122#1588122
Es ging darum Daten aller Dateien von einem Pfad inkl. Unterordner in einer Datei zusammenzuführen. Dies klappt auch wunderbar. Jetzt würde ich gern noch jede Zeile mit dem Dateinamen erweitern, aus welcher dieser Datensatz stammt.
Das Ausgangsmakro wäre also wie folgt
Option Explicit
'Quelle: https://www.herber.de/forum
'Modifiziert: fcs 2017-10-27
Public glngFile As Long, garrFiles() As String
Sub ListFilesInFolder(ByVal SourceFolderName As String, _
Optional DateiFormat As String = "*.*", _
Optional IncludeSubfolders As Boolean = False)
'Makro erstellt entsprechend den Parametern ein Daten-Array mit den Namen _
der Dateien im Verzeichnis, ggf. inkl. Unterverzeichnissen
'1.Parameter Ordner, wo soll gesucht werden?
'2.Parameter Dateifilter, ggf. * als Platzhalter verwenden
'3.Parameter mit Unterordner = True, False ist ohne
'Erstellt gemäß Suchkriterien ein Array mit den Dateinamen - inklusive Pfad
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Dim Status As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein
For Each FileItem In SourceFolder.Files
If LCase(FileItem.Name) Like LCase(DateiFormat) Then
glngFile = glngFile + 1
ReDim Preserve garrFiles(1 To glngFile)
'Pfad\Dateiname
garrFiles(glngFile) = FileItem.Path
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, DateiFormat, IncludeSubfolders
Next SubFolder
End If
Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub
Sub Import()
' Alle *.xls* eines Verzeichnisses in 1 (das aktuelle) Sheet importieren
Dim FullName As String
Dim wbkZiel As Workbook
Dim z As Integer 'Zähler für Durchläufe
Dim lngFile As Long
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.AskToUpdateLinks = False
.DisplayAlerts = False
.EnableEvents = False
End With
Const Pfad = "C:\Test\" '*** ANPASSEN ***
Const Extension = "*.xls*" '*** ANPASSEN ***
Const MitKopfzeile = False '*** ANPASSEN ***
'Dateiliste zurücksetzen
glngFile = 0
Erase garrFiles
'Dateiliste erstellen
Call ListFilesInFolder(SourceFolderName:=Pfad, _
DateiFormat:=Extension, _
IncludeSubfolders:=True)
If glngFile = 0 Then
MsgBox "Keine Excel-Dateien im Verzeichnis """ & Pfad & """ gefunden!"
goto ErrorHandler
End If
'Prüfung, ob Ziel-Sheet leer ist
If WorksheetFunction.CountA(Cells) > 0 Then
If MsgBox("Das Tabellenblatt ist nicht leer," & vbCrLf _
& "sollen die Daten gelöscht werden?", vbCritical + vbYesNo, _
"Warn-Hinweis") = vbYes Then
Cells.Delete
Else
z = 1
End If
End If
'Dateiliste abarbeiten
For lngFile = 1 To glngFile
FullName = garrFiles(lngFile)
Call CopyData(FullName, MitKopfzeile, z)
z = z + 1
Next
'Dateiliste zurücksetzen
glngFile = 0
Erase garrFiles
ErrorHandler:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.AskToUpdateLinks = True
.DisplayAlerts = True
.EnableEvents = True
End With
Dim intRow As Integer, intLastRow As Integer
intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
For intRow = intLastRow To 1 Step -1
If Application.CountA(Rows(intRow)) = 0 Then
intLastRow = intLastRow - 1
Else
Exit For
End If
Next intRow
For intRow = intLastRow To 1 Step -1
If IsEmpty(Cells(intRow, 1)) Then
Rows(intRow).Delete
End If
Next intRow
End Sub
Vorab schon mal vielen Dank für die Bemühungen und Eure Hilfe.
Gruß Benni