Mehrere Excel Dateien zu einer zusammenfassen

[Kongur]

Hallo zusammen,

kurze Schilderung des Problems.
Ich habe einen Ordner mit einer variablen Anzahl an Excel Dateien, fester Pfad.
Jetzt habe ich einen VBA Code der mir alle Informationen aus allen Excel Dateien in eine Tabelle(immer das selbe Sheet) konsolidiert, A1 ist immer die gleiche Überschrift.
Da es alles automatisch Ablaufen soll, habe ich das Problem das bei dem Code ein Popup kommt wo ich die Daten auswählen soll (händisch).
Inwiefern muss ich den Code verändern, damit ich mit einem Klick alle Daten habe, wie es der Code beschreibt aber nicht die händische Auswahl tätigen muss?

Code:

Sub zusammenfügen()
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 (*.xlsx),*.xlsx", 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 SaveChanges:=True 'Neu
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

[GMG-CC]

Moin,
mal nachgefragt: Warum VBA wo du doch mit 2016 Möglichkeiten hast, das Ganze ohne eine Zeile VBA-Code zu lösen?

[Kongur]

Das ganze soll später aus Access heraus funktionieren.
Access soll auf diese Zusammengefasste Excel Tabelle zugreifen.
In Access gibt es dann ein Button der dieses Makro auslöst und da die Daten sich kontinuierlich ändern muss das ein Makro sein.



Private Sub Cmdzusammenfügen_Click()
Dim xlApp As Object
Dim sFile As String

sFile = "Hier steht der Pfad"
Set xlApp = CreateObject("Excel.Application")
xlApp.Workbooks.Open sFile
xlApp.Run "zusammenfügen"
xlApp.Workbooks.Close

Set xlApp = Nothing
End Sub

[Case]

Hallo,  :19:

In Access gibt es dann ein Button der dieses Makro auslöst und da die Daten sich kontinuierlich ändern muss das ein Makro sein.

Wenn es von Access aus laufen soll, würde ich trotzdem die Exceldatei mit PowerQuery aufbereiten und dann nach folgendem Muster vorgehen:  :21:

Aus AEK 20 der letzte Download (PowerQuery)...

Du musst dich natürlich erst Mal mit PQ auseinandersetzen. 

Im Anhang noch eine Möglichkeit für Excel (Anpassungen nicht vergessen - siehe Kommentar im Code).

[Kongur]

Hat funktioniert,

Vielen Vielen Dank :)