Excelsheet in PDF speichern

' IncludeDocProperties = True >> Dokumenteigenschaften werden eingeschlossen ' IgnorePrintAreas = False >> festgelegte Druckbereiche werden übernommen ' OpenAfterPublish = True >> Dokument wird nach dem speichern nochmal angezeigt Private Sub CmdPDF_Click() ' Dateiname ist Datum aus "K12" ' MsgBox ist eine optionale Komponente ' Rückfragen, ob Datei nach dem Erstellen geöffnet werden soll If MsgBox("Soll die PDF-Datei nach dem Erstellen angezeigt werden?" _ , vbYesNo, "PDF anzeigen? _ _ _ ") _ = vbYes Then pdfOpenAfterPublish = True ' Vorgaben zum speichern des Dokuments ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ ("C:\Testdatei\Monat") _ & "\" & Range("K12").Value & ".pdf", _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=IIf(pdfOpenAfterPublish, True, False) '(in Kombination mit MsgBox) ' OpenAfterPublish = True (wenn keine MsgBox gewünscht ist) End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub CmdPDF_Click() ' Dateiname ist Datum aus "K12" Dim pdfOpenAfterPublish As Boolean Dim strFile As String Dim strPfad As String ' MsgBox ist eine optionale Komponente ' Rückfragen, ob Datei nach dem Erstellen geöffnet werden soll If MsgBox("Soll die PDF-Datei nach dem Erstellen angezeigt werden?", vbYesNo, _ "PDF anzeigen?") = vbYes Then pdfOpenAfterPublish = True ' Vorgaben zum speichern des Dokuments strPfad = "C:\Testdatei\" 'Basis-Verzeichnis in dem die Dateien gespeichert werden sollen ' strPfad = "C:\Users\Public\Test\PDF\" With ActiveSheet.Range("K12") 'Jahres-Unter-Verzeichnis aus Datum generieren strPfad = strPfad & VBA.Format(.Value, "YYYY") Call prcMakeDir(strPfad) 'Monats-Unter-Verzeichnis aus Datum generieren strPfad = strPfad & Application.PathSeparator & VBA.Format(.Value, "MMMM") Call prcMakeDir(strPfad) 'Name PDF-Datei aus Datum generieren strFile = strPfad & "\" & VBA.Format(.Value, "YYYYMMDD") & ".pdf" End With 'PDF erstellen ActiveSheet.Range("A6:AX60").ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=strFile, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=IIf(pdfOpenAfterPublish, True, False) '(in Kombination mit MsgBox) _ ' OpenAfterPublish = True (wenn keine MsgBox gewünscht ist) End Sub Sub prcMakeDir(ByVal Verzeichnis) 'Erstellt Verzeichnis, wenn noch nicht vorhanden If Dir(Verzeichnis, vbDirectory) = "" Then VBA.MkDir Verzeichnis End If End Sub

Hallo Franz,
DANKE +++ für deine schnelle Hilfe.
Dein Code hat auf Anhieb sauber funktioniert und was mir noch sehr gut gefallen hat:
einfach, übersichtlich,- und beschriftet.
Super, da hat das Testen wirklich Spaß gemacht.
Nun hätte ich noch eine Bitte;
kann man in den Code mit einbinden das die gesamte Excel Arbeitsmappe .xlsm
mit abgespeichert werden soll?
Wenn das geht, hat man dann am Monatsende recht viele (gemischte .pdf & .xlsm)
Dateien im Ordner liegen - was die Übersicht auch nicht besser macht.
Die .pdf müssen 15 Jahre archiviert werden und die Exceldateien sind nur aufgeblasene
Arbeitsmappen mit teilweise nicht archivierungspflichtigem Inhalt.
Nun hab ich mir überlegt das man nur die letzten 7 Exceldadeien vorhält
und alle anderen löscht.
Dies könnte beispielsweise automatisch geschehen - Nur wie?
Habt ihr vielleicht Ideen zum Thema?
Notfalls müsste halt händisch gelöscht werden ;)
Danke und spätabendliche Grüße,
Jens

Hallo Jens,
das Erstellen einer Kopie der Exceldatei mit dem gleichen Namne wie die PDF ist kein Problem.
Das löschen älterer xlsm-Dateien ist schon etwas aufwendiger
In der folgenden Version bleiben in jedem Monat 7 Excel-Dateien übrig.
Wenn man die dies noch monatsübergreifend weiter treiben will, dann wird es deutlich kompliierter.
Gruß
Franz


Private Sub CmdPDF_Click()  ' Dateiname ist Datum aus "K12"
Dim pdfOpenAfterPublish As Boolean
Dim strFile As String
Dim strPfad As String
Dim strExcel As String
'   MsgBox ist eine optionale Komponente
'   Rückfragen, ob Datei nach dem Erstellen geöffnet werden soll
If MsgBox("Soll die PDF-Datei nach dem Erstellen angezeigt werden?", vbYesNo, "PDF anzeigen? _
") _
= vbYes Then pdfOpenAfterPublish = True
'   Vorgaben zum speichern des Dokuments
strPfad = "C:\Testdatei\" 'Basis-Verzeichnis in dem die Dateien gespeichert werden sollen
strPfad = "C:\Users\Public\Test\PDF\"
With ActiveSheet.Range("K12")
'Jahres-Unter-Verzeichnis aus Datum generieren
strPfad = strPfad & VBA.Format(.Value, "YYYY")
Call prcMakeDir(strPfad)
'Monats-Unter-Verzeichnis aus Datum generieren
strPfad = strPfad & Application.PathSeparator & VBA.Format(.Value, "MMMM")
Call prcMakeDir(strPfad)
'Name PDF-Datei aus Datum generieren
strFile = strPfad & "\" & VBA.Format(.Value, "YYYYMMDD") & ".pdf"
strExcel = strPfad & "\" & VBA.Format(.Value, "YYYYMMDD") & ".xlsm"
End With
'PDF erstellen
ActiveSheet.Range("A6:AX60").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=strFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=IIf(pdfOpenAfterPublish, True, False)     '(in Kombination mit MsgBox) _
'   OpenAfterPublish = True  (wenn keine MsgBox gewünscht ist)
'Excel-Kopie erstellen
ActiveWorkbook.SaveCopyAs strExcel
Call prcDeleteOldFiles(Verzeichnis:=strPfad, Filter:="*.xlsm", NumFiles:=7)
End Sub
Sub prcMakeDir(ByVal Verzeichnis)
'Erstellt Verzeichnis, wenn noch nicht vorhanden
If Dir(Verzeichnis, vbDirectory) = "" Then
VBA.MkDir Verzeichnis
End If
End Sub
Sub prcDeleteOldFiles(byvalVerzeichnis As String, ByVal Filter As String, _
Optional ByVal NumFiles As Integer = 1)
Dim fsO As Object, fsFolder As Object, fsFile
Dim arrFiles() As String, intCount As Integer
'Makro geeignet für Dateien, deren Name mit dem Datum im Format JJJJ-MM-DD beginnt oder _
anderem Wert am Begin des Dateinamens der für neuere Dateien aufsteigend ist.
'Verzeichnis = Dateiverzeichnis in dem Dateien gelöscht werden sollen
'Filter = Filter für die Dateisuche
'NumFiles = Anzahl der neuesten Dateien, die nicht gelöscht werden sollen
If Filter = "*.*" Then
MsgBox "Als Filter wurde ""*.*"" gewählt, " _
& "Dieser Filter würde alle Dateien im Ordner löschen!" _
& vbLf & "Makro wird abgebrochen", _
vbOKOnly + vbInformation, "Makro: prcDeleteOldFiles"
Exit Sub
End If
Set fsO = CreateObject("Scripting.FileSystemObject")
Set fsFolder = fsO.GetFolder(Verzeichnis)
For Each fsFile In fsFolder.Files
If fsFile.Name Like Filter Then
intCount = intCount + 1
ReDim Preserve arrFiles(1 To intCount)
arrFiles(intCount) = fsFile.Name
End If
Next
If intCount > NumFiles Then
If intCount > 1 Then
Call Quicksort(arrFiles, LBound(arrFiles), UBound(arrFiles))
End If
For intCount = 1 To UBound(arrFiles) - NumFiles
Kill pathname:=Verzeichnis & "\" & arrFiles(intCount)
Next
End If
Set fsO = Nothing
Set fsFolder = Nothing
End Sub
'######   Quicksort - Sortiert eine einspaltige Datenliste aufsteigend   ######
Public Function Quicksort(Data, links, rechts)
'Sortieren einer einspaltigen Datenliste
'links und rechts geben die Nummern der der Elemente an, die sortiert werden sollen
'normalerweise nimmt man das 1. und letzte Element
Dim Teiler As Long
If rechts > links Then
Teiler = Teile(Data, links, rechts)
Call Quicksort(Data, links, Teiler - 1)
Call Quicksort(Data, Teiler + 1, rechts)
End If
End Function
Private Function Teile(Data, links, rechts)
Dim Index As Long
Dim i As Long
Index = links
For i = links To rechts - 1
If Data(i)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Excelsheet in PDF speichern

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread