Hallöchen,
dann mal nur ein Tipp - den ständigen Wechsel zwischen den Blättern zwecks kopieren und einfügen kannst Du Dir sparen - im Prinzip so:
Sheets("Tabelle1").Range("A1").Copy Sheets("Tabelle2").Range("A1")
Moin!
Die gewünschte Manöverkritik!
Eine neue Datei zunächst als .xlsx zu speichern, um sie später zu löschen, ist irgendwie kontraproduktiv. ;)
Du hast keinerlei Fehlerbehandlung, Du gehst davon aus, dass
- der Speicherpfad existiert
- die Workbooks geöffnet sind und das jeweilige Blatt existiert.
- Actvate ist hier nicht nur überflüssig, sondern verlangsam die Ausführung enorm
Ich verfolge einen anderen Ansatz:
Ich erstelle das Verzeichnis, falls noch nicht existent,
benutze eine With-Klammer für das neue Workbook,
prüfe per Select Case den Namen der geöffneten Workbooks
kopiere das jeweilige erste Blatt in die neue Mappe
exportiere mit den Defaults.
Im Endeffekt macht mein Code nix anderes als Deiner, geht aber eher als Programm durch, da der DAU hier keine Fehler machen kann.
Modul Modul1Option Explicit
Private Declare Function MakePath& Lib "imagehlp.dll" Alias _
"MakeSureDirectoryPathExists" (ByVal sPath$)
Sub RPP()
Dim WKB As Workbook, strPath$
strPath = Environ("UserProfile") & "\Desktop\Testdateien\pdf\"
'prüft, ob Pfad existiert und erstellt ihn bei Bedarf
MakePath strPath
'erstellt neue Mappe mit nur einem Sheet
With Workbooks.Add(xlWBATWorksheet)
'Schleife über alle geöffneten Workbooks
For Each WKB In Application.Workbooks
Select Case WKB.Name
'Außer neuem Workbook und Personal.xlsb
Case .Name, "PERSONAL.XLSB"
'mache nix!
Case Else
'jeweils das linke Blatt in neue Mappe kopieren
WKB.Worksheets(1).UsedRange.Copy .Sheets.Add.Cells(1)
End Select
Next
'als PDF mit Zeitstempel speichern
.ExportAsFixedFormat xlTypePDF, _
strPath & "Sammelblatt" & Format(Now, "yyyymmdd_hhmmss")
'ohne Speichern schließen
.Close False
End With
End Sub
Gruß Ralf