VBA - An bestehende pdf anhängen

[schauan]

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")

[RPP63]

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 Modul1

Option 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