Excelsheet in PDF speichern

Hallo Leute,
nach gefühlten 1000 gelesenen google-Lösungen möchte ich nun hier doch mal nachfragen.
Ich möchte doch weiter nichts wie ein Tabellenblatt in ein PDF abspeichern
Aber zu meinen Bedingungen, die da wären:
- Der Name soll sich aus dem Datum von Zelle "K12" im Format YYYYMMDD ergeben
> hierzu muss also das Datumsformat dd.mm.yyy aus "K12" umgewandelt werden.
- Die Ordnerstruktur ist Jahr\(Janur, Februar, ...,Dezember)
(diese könnte ja zu Jahresbeginn angelegt werden - ist wohl das einfachste)
> Nun muss das Datum aus "K12" mit der Ordnerstruktur geprüft werden
um das Dokument auch im richtigen Jahr und Monat abzulegen.
Bisher hatte ich den Druckbereich in Excel festgelegt
(sonst werden mehrere unbrauchbare Blätter gedruckt!)
Muss das so sein oder kann ich den Bereich Range("A6:AX60")
auch im Code festlegen und dafür sind die Exceleinstellungen schnuppe
Danke für Eure Hilfe
Bisher benutzt:


'   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

als Beispielmappe
https://www.herber.de/bbs/user/108816.xlsm

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)

Forumthread: Excelsheet in PDF speichern

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial