Der nachfolgende Code gehört in ein "Allgemeines Modul" ( siehe Code aus Forum ) der neuen Zieldatei. Nach Starten des Codes kann über ein Auswahlfenster der gewünschte Ordner geöffnet und eine, mehrere oder alle ( Strg + a ) Dateien markiert werden. Es werden dann alle ausgewählten Dateien geöffnet und der Inhalt von Spalte A bis Z untereinander gelistet.
 
Der Code für ein allgemeines Modul:
Public Sub Daten_mehrerer_Dateien_zusammenfuehren()
'Code für ein allgemeines Modul
'********************************
'Autor: Jürgen Hennekes
'********************************
On Error GoTo errExit
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim varDateien As Variant
Dim lngAnzahl As Long
Dim lngLastQ As Long
Set WBZ = ActiveWorkbook
'Altdaten auf Zielblatt löschen
WBZ.Worksheets(1).Range("A2:IV65536").ClearContents
varDateien = _
Application.GetOpenFilename("Datei (*.xls),*.xls", False, "Bitte gewünschte Datei(en) markieren", False, True)
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
For lngAnzahl = LBound(varDateien) To UBound(varDateien)
Set WBQ = Workbooks.Open(Filename:=varDateien(lngAnzahl))
lngLastQ = WBQ.Worksheets(1).Range("A65536").End(xlUp).Row
WBQ.Worksheets(1).Range("A2:Z" & lngLastQ).Copy _
Destination:=WBZ.Worksheets(1).Range("A" & WBZ.Worksheets(1).Range("A65536").End(xlUp).Row + 1)
WBQ.Close
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "Es wurden " & UBound(varDateien) & " Dateien zusammengefügt.", 64
Exit Sub
errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
If Err.Number = 13 Then
MsgBox "Es wurde keine Datei ausgewählt"
Else
MsgBox "Es ist ein Fehler aufgetreten!" & vbCr _
& "Fehlernummer: " & Err.Number & vbCr _
& "Fehlerbeschreibung: " & Err.Description
End If
End Sub
Sollen aus den Quelldateien alle Tabellenblätter ausgelesen werden, so geht das mit nachfolgendem Code.
Für dieses Beispiel wird von folgendem Tabellenaufbau der Quelldateien ausgegangen:
1. Die Daten stehen in allen Tabellenblättern gleicher Tabellenstruktur.
2. Die Daten beginnen in der ersten Zeile (Spalte A) mit einer Überschrift, der erste Datensatz steht in Zeile 2 usw.
3. Mittels Spalte A wird die Anzahl der Datensätze ermittelt. Es sollten unterhalb des letzten zu kopierenden Datensatzes keine weiteren Daten stehen.
Public Sub Daten_mehrerer_Dateien_zusammenfuehren2()
'Code für ein allgemeines Modul
'********************************
'Autor: Jürgen Hennekes
'********************************
On Error GoTo errExit
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim intSh As Integer
Dim varDateien As Variant
Dim lngAnzahl As Long
Dim lngLastQ As Long
Set WBZ = ActiveWorkbook
'Altdaten auf Zielblatt löschen
WBZ.Worksheets(1).Range("A2:IV65536").ClearContents
varDateien = _
Application.GetOpenFilename("Datei (*.xls),*.xls", False, "Bitte gewünschte Datei(en) markieren", False, True)
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
For lngAnzahl = LBound(varDateien) To UBound(varDateien)
Set WBQ = Workbooks.Open(Filename:=varDateien(lngAnzahl))
For intSh = 1 To WBQ.Worksheets.Count
lngLastQ = WBQ.Worksheets(intSh).Range("A65536").End(xlUp).Row
WBQ.Worksheets(intSh).Range("A2:Z" & lngLastQ).Copy _
Destination:=WBZ.Worksheets(1).Range("A" & WBZ.Worksheets(1).Range("A65536").End(xlUp).Row + 1)
Next
WBQ.Close
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "Es wurden " & UBound(varDateien) & " Dateien zusammengefügt.", 64
Exit Sub
errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
If Err.Number = 13 Then
MsgBox "Es wurde keine Datei ausgewählt"
Else
MsgBox "Es ist ein Fehler aufgetreten!" & vbCr _
& "Fehlernummer: " & Err.Number & vbCr _
& "Fehlerbeschreibung: " & Err.Description
End If
End Sub
|
||||||||||||||||||||||||||||||||||||||||||||
