AW: Listen Zusammenführen -aus vielen Dateien
05.05.2020 15:01:12
fcs
Hallo Ulli,
ich hab das Makro in alle Richtungen angepasst,
Startverzeichnis bei der Ordnerauswahl ist der Speicherort der Datei
Bei der Suche nach Dateien werden alle Unterverzeichnisse des gewählten Ordners durchsucht
Die geöffnete Zieldatei wird beim Import aus den Dateien übersprungen
Fehler 1004: Dieser Fehler wurde von der temporären Datei verursacht, die Exel beim Öffnen von Dateien anlegt. Deren Name beginnt immer mit "~" - ich hab eine entsprechende Prüfung eingebaut.
LG
Franz
Option Explicit
'Quelle: http://www. _
herber.de/forum/archiv/1064to1068/t1064122.htm#1064890
'Modifiziert: Franz Sielck 2010-08-07
Public lCount As Long, arrFiles() As String
Sub ListFilesInFolder(ByVal SourceFolderName As String, _
Optional DateiFormat As String = "*.*", _
Optional IncludeSubfolders As Boolean = False, _
Optional FolderName As Boolean = False)
'1.Parameter Ordner, wo soll gesucht werden?
'2.Parameter Datei,* als Platzhalter verwenden,Optional leer ist alle
'3.Parameter mit Unterordner = True, Optional False ist ohne
'4.Parameter kompl. Pfad ausgeben = True, Optional nur Dateiname = False
'Erstellt gemäß Suchkriterien ein Array mit den Dateinamen - optional inkl. Pfad
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
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
lCount = lCount + 1
ReDim Preserve arrFiles(1 To lCount)
arrFiles(lCount) = IIf(FolderName, FileItem, FileItem.Name)
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, DateiFormat, IncludeSubfolders, FolderName
Next SubFolder
End If
Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub
Sub DatenImportieren()
' DatenImportieren Makro
Dim sVerzeichnis$, sDatei$
Dim wbZiel As Workbook, wbQuelle As Workbook
Dim wksZiel As Worksheet, wksQuelle As Worksheet
Dim ZeileZ&, FileCount&
Dim Spalte&
Dim ZeileQ&
Const StartZeile& = 6 '1. Auszulesende Zeile in Tabelle 1
Const Schritt& = 1 'Spaltenabstand der auszulesenden Zellen
On Error GoTo Fehler
'neue Datei mit einem Tabellenblatt für Ergebnisdaten erstellen
Set wbZiel = ThisWorkbook
'Zieltabellenblatt Objektvariable zuweisen
Set wksZiel = wbZiel.Worksheets("Maßnahmenliste_Komplett")
With wksZiel
ZeileZ = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte Zeile mit Daten
If ZeileZ >= StartZeile Then
.Range(.Cells(StartZeile, 1), .Cells(ZeileZ, 7)).ClearContents
End If
ZeileZ = StartZeile - 1
End With
'Suchverzeichnis auswahlen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner mit zu durchsuchenden Dateien wählen"
.ButtonName = "Auswählen"
.InitialFileName = wbZiel.Path & Application.PathSeparator
If .Show = -1 Then
sVerzeichnis = .SelectedItems(1)
'Variablen zur Dateisuche zurücksetzen
lCount = 0
Erase arrFiles
'Dateisuche starten
Call ListFilesInFolder(SourceFolderName:=sVerzeichnis, _
DateiFormat:="**.xls**", _
IncludeSubfolders:=True, _
FolderName:=True)
If lCount = 0 Then
MsgBox "Keine Ecxeldateien im Verzeichnis" & vbLf & sVerzeichnis _
& vbLf & " gefunden.", vbOKOnly, "Imort von Maßnahmen"
GoTo Fehler
End If
Else
GoTo Fehler
End If
End With
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For lCount = 1 To UBound(arrFiles)
sDatei = Mid(arrFiles(lCount), InStrRev(arrFiles(lCount), "\") + 1)
If Not (LCase(sDatei) = LCase(wbZiel.Name) Or Left(sDatei, 1) = "~") Then
FileCount = FileCount + 1
Application.StatusBar = "Datei, laufende Nr. " & FileCount & " wird bearbeitet."
'Quelldatei schreibgeschützt öffnen
Set wbQuelle = Workbooks.Open(Filename:=arrFiles(lCount), _
ReadOnly:=True, UpdateLinks:=False)
'Tabelle1 Objektvariable zuweisen
Set wksQuelle = wbQuelle.Worksheets(4) 'Blatt"Übertrag to do"
'Werte aus Blatt 1 auslesen
ZeileQ = StartZeile
Do While wksQuelle.Cells(ZeileQ, 2) ""
ZeileZ = ZeileZ + 1
With wksZiel
'lfd. Nr. in Spalte A eintragen
.Cells(ZeileZ, 1).Value = ZeileZ - StartZeile + 1
'Dateiname in Spalte B eintragen
.Cells(ZeileZ, 2).Value = Left(wbQuelle.Name, InStrRev(wbQuelle.Name, ".") - 1)
'Werte aus den Spalten übertragen
For Spalte = 3 To 6
.Cells(ZeileZ, Spalte) = wksQuelle.Cells(ZeileQ, Spalte - 1).Value
Next
End With
'Nächste Zeile setzen
ZeileQ = ZeileQ + Schritt
Loop
wbQuelle.Close savechanges:=False
Set wksQuelle = Nothing
Set wbQuelle = Nothing
End If
Next lCount
'Werte zurücksetzen
Erase arrFiles
lCount = 0
Application.ScreenUpdating = True
MsgBox "Alle Dateien ausgelesen"
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
Application.ScreenUpdating = True
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
End Select
End With
Set wbZiel = Nothing
Set wbQuelle = Nothing
With Application
.EnableEvents = True
.StatusBar = False
End With
End Sub