Der nachfolgende Code gehört in ein "Allgemeines Modul" ( siehe Code auf 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
|
||||||||||||||||||||||||||||||||||||||||||||
