Excel Dateien aus einem Ordner zusammenfügen

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Excel Dateien aus einem Ordner zusammenfügen
von: Foradh
Geschrieben am: 23.04.2015 13:16:57

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

Bild

Betrifft: AW: Excel Dateien aus einem Ordner zusammenfügen
von: Martin
Geschrieben am: 23.04.2015 17:17:29
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

Bild

Betrifft: Kleine Korrektur
von: Martin
Geschrieben am: 23.04.2015 17:20:07
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

Bild

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

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Excel Dateien aus einem Ordner zusammenfügen"