Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Excel Dateien aus einem Ordner zusammenfügen

Excel Dateien aus einem Ordner zusammenfügen
23.04.2015 13:16:57
Foradh
Hallo liebe Excel-Freunde,
ich habe zu Zeit folgendes Problem...und zwar würde ich gerne aus einem Ordner alle Excel- _
Dateien zu in eine Datei zusammenfügen. Ablauf: Ich erstelle eine leere Excel Datei in dem _
Ordner aus dem ich die Excel Dateien zusammenfügen möchte und starte ein Makro. Hierzu habe ich _ folgenden Ansatz bereits im Netz gefunden.

Public Sub Daten_mehrerer_Dateien_zusammenfuehren()
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

Was ich hier gerne ändern würde, wäre dass er mich nicht nach den Dateien fragt, sondern einfach die Dateien aus dem Ordner nimmt, aus dem ich die Makro Datei starte.
Könnte mir hier jmd helfen?
Vielen Dank
Foradh

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Excel Dateien aus einem Ordner zusammenfügen
23.04.2015 17:17:29
Martin
Hallo Foradh,
versuche es mal so:
Public Sub Daten_mehrerer_Dateien_zusammenfuehren()
On Error GoTo errExit
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim lngLastQ As Long
Dim strFileXLS As String
Set WBZ = ActiveWorkbook
'Altdaten auf Zielblatt löschen
WBZ.Worksheets(1).Range("A2:IV65536").ClearContents
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
strFileXLS = Dir(ThisWorkbook.Path & "\*.xls")
Do While strFileXLS  ""
If ThisWorkbook.Path & "\" & strFileXLS  ThisWorkbook.FullName Then
Debug.Print ThisWorkbook.Path & "\" & strFileXLS
Set WBQ = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & strFileXLS)
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
End If
strFileXLS = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Wenn es sich um xlsx-Dateien handelt, muss du die Zeile
strFileXLS = Dir(ThisWorkbook.Path & "\*.xls")

durch
strFileXLS = Dir(ThisWorkbook.Path & "\*.xlsx")

austauschen.
Viele Grüße
Martin

Anzeige
Kleine Korrektur
23.04.2015 17:20:07
Martin
Ich hatte vergessen die OnError-Sprungmarke zu entfernen. Bitte nimm fogenden Code:
Public Sub Daten_mehrerer_Dateien_zusammenfuehren()
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim lngLastQ As Long
Dim strFileXLS As String
Set WBZ = ActiveWorkbook
'Altdaten auf Zielblatt löschen
WBZ.Worksheets(1).Range("A2:IV65536").ClearContents
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
strFileXLS = Dir(ThisWorkbook.Path & "\*.xls")
Do While strFileXLS  ""
If ThisWorkbook.Path & "\" & strFileXLS  ThisWorkbook.FullName Then
Set WBQ = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & strFileXLS)
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
End If
strFileXLS = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Gruß,
Martin

Anzeige
AW: Kleine Korrektur
24.04.2015 07:29:28
Foradh
Der Code funktioniert wunderbar!!! Vielen Vielen Dank dafür.

310 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige