AW: Aus mehreren Excel Arbeitsblättern eines
10.03.2016 16:17:35
Michael
Hallo Alois!
Weil ich heute schon eine ähnliche Geschichte als PDF-Zusammenfassung hier im Forum eingestellt habe, hier für .xlsm-Dateien: in ein allgemeines Modul
Sub MappenZusammenfassen()
Dim SuchDialog As FileDialog
Dim Pfad As String
Dim Datei As String
Dim QuellMappe As Workbook
Dim ZielMappe As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ZielMappe = Workbooks.Add
'Auswahl-Dialog für durchsuchtes Verzeichnis
Set SuchDialog = Application.FileDialog(msoFileDialogFolderPicker)
With SuchDialog
.Title = "Bitte Verzeichnis wählen"
.AllowMultiSelect = False
If .Show -1 Then
MsgBox "Vorgang abgebrochen", vbInformation
Exit Sub
Else: Pfad = .SelectedItems(1) & "\"
End If
End With
'Durchlaufen der .xlsm-Dateien im o.a. Verzeichnis
Datei = Dir(Pfad & "*.xlsm", vbDirectory)
'Abbruch wenn keine .xlsm-Dateien im o.a. Verzeichnis sind
If Len(Datei) = 0 Then
MsgBox "Keine Excel-Datei vorhanden. Abbruch!"
Exit Sub
End If
'Mappen in ausgewählten Verzeichnis nacheinander öffnen
'Jeweils erstes Blatt in neue Mappe kopieren
Do While Len(Datei) > 0
Set QuellMappe = Workbooks.Open(Filename:=Pfad & Datei)
With QuellMappe
.Worksheets(1).Copy _
after:=ZielMappe.Worksheets(ZielMappe.Worksheets.Count)
.Close savechanges:=False
End With
Datei = Dir
Loop
'Neue Mappe im o.a. Pfad speichern
With ZielMappe
.Worksheets(1).Delete
.SaveAs Filename:=Pfad & "Zusammen", FileFormat:=52
.Close savechanges:=False
End With
'Aufräumen
Set QuellMappe = Nothing
Set ZielMappe = Nothing
Set SuchDialog = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Damit erhältst Du eine Pfad-Auswahl, alle .xlsm-Dateien in dem Pfad werden durchgegangen und deren jeweils erstes Blatt in eine neue Mappe kopiert. Diese Mappe wird dann in den angegebenen Pfad als "Zusammenfassung.xlsm" gespeichert.
LG
Michael