PDA

Vollständige Version anzeigen : Mehrere Exceldateien zusammenführen.


Jsch
09.07.2014, 09:35
Hallo zusammen,
ich bin VBA-Anfänger und bräuchte einmal Eure Unterstützung.
Ich möchte mehrere Exceldateien in einer Datei zusammenführen, d.h. eimal im Monat mochte ich in der Hauptdatei in einem festgelegten Tabellenblatt die Daten aus den anderen Dateien einlesen. Ich habe unteren VBA-Code im Internet gefunden und entsprechend meiner Daten angepasst was auch gut funktioniert. Ich habe jetzt nur das Problem das in den anderen Dateien Zeilen mit autofilter ausgeblendet wurden und diese somit leider nicht mitkopiert werden. Kann mie einer helfen was ich im Code ändern muss damit auch ausgeblendete Zeilen mitkopiert werde. Jetzt schon einmal vielen Dank füe Eure Hilfe.
Gruß
JSch
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(8).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:AC" & lngLastQ).Copy _
Destination:=WBZ.Worksheets(8).Range("A" & WBZ.Worksheets(8).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

Jsch
10.07.2014, 11:37
Hallo zusammen,
kann mir den wirklich keiner bei meinem Problem helfen.

Gruß
Jürgen

Mc Santa
10.07.2014, 11:48
Hallo,

setze in deinen Code mal folgendes ein und berichte, ob es funktioniert:

[...]
For lngAnzahl = LBound(varDateien) To UBound(varDateien)
Set WBQ = Workbooks.Open(Filename:=varDateien(lngAnzahl))
With WBQ.Worksheets(1)
If .AutoFilterMode Then _
If .AutoFilter.FilterMode Then _
.AutoFilter.ShowAllData
lngLastQ = .Range("A65536").End(xlUp).Row
.Range("A2:AC" & lngLastQ).Copy _
Destination:=WBZ.Worksheets(8).Range("A" & WBZ.Worksheets(8).Range("A65536").End(xlUp).Row + 1)
End With
WBQ.Close
Next
[...]


VG

Jsch
10.07.2014, 14:15
Hallo McSanta,
vielen, vielen Dank, der Code funktioniert super, Du hast mir wirklich sehr geholfen.
Viele Grüße
Jürgen