per Button in Ordner speichern

Private Sub Create_PDF_Data_Click() ChDir "C:\Users\Desktop" 'Speicherort angeben ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ ("test - ") & ("KW ") & Application.WorksheetFunction.WeekNum(Date, 21) & Format(Date, " - _ dddd, yyyy/mm.dd") & ".pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False ' _ Dateiname definieren End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub a() Const PFAD$ = "C:\Users\Desktop\" 'anpassen Const PRE$ = "Test - KW " 'anpassen Const SUF$ = ".pdf" 'anpassen Dim Wb As Workbook: Set Wb = ThisWorkbook Dim Ws As Worksheet: Set Ws = Wb.ActiveSheet Dim Mon, Verz$, DName$ Mon = Array("Jänner", "Februar", "März", "April", "Mai", "Juni", "Juli", _ "August", "September", "Oktober", "November", "Dezember") DName = Application.WorksheetFunction.WeekNum(Date, 21) & _ Format(Date, " - dddd, yyyy/mm.dd") 'Verzeichnis-Name aus aktuellem Monat erstellen Verz = Mon(Month(Date) - 1) 'Verzeichnis anlegen, wenn noch nicht vorhanden If Dir(PFAD & Verz, vbDirectory) = "" Then MkDir PFAD & Verz Ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PFAD & Verz & "\" & PRE & DName & SUF, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False MsgBox "PDF-Export abgeschlossen!" Set Wb = Nothing: Set Ws = Nothing: Erase Mon End Sub

Private Sub Create_PDF_Data_Click() Const PFAD$ = "C:\Users\Desktop\" Const PRE$ = "test - KW " Const SUF$ = ".pdf" Dim Wb As Workbook: Set Wb = ThisWorkbook Dim Ws As Worksheet: Set Ws = Wb.ActiveSheet Dim Mon, Year, Verz$, DName$ Mon = Array("Januar", "Februar", "März", "April", "Mai", "Juni", "Juli", _ "August", "September", "Oktober", "November", "Dezember") Year = Array("2015", "2016", "2017", "2018", "2019", "2020") DName = Application.WorksheetFunction.WeekNum(Date, 21) & _ Format(Date, " - dddd, yyyy/mm.dd") 'Verzeichnis-Name aus aktuellem Monat erstellen Verz = Year & Mon(Month(Date) - 1) 'Verzeichnis anlegen, wenn noch nicht vorhanden If Dir(PFAD & Verz, vbDirectory) = "" Then MkDir PFAD & Verz Ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PFAD & Verz & "\" & PRE & DName & SUF, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False Set Wb = Nothing: Set Ws = Nothing: Erase Mon End Sub

Harti,
...muss zunächst geprüft werden, ob die Datei schon existiert, und wenn ja, der Speichername (Dateiname) entsprechend ergänzt werden (zB mit einer laufenden Nummer). Dafür gibt's verschiedene Strategien und Wege, ich hab's jetzt mal in den Code eingepflegt, den ich oben als erstes gepostet habe, inkl. Kommentar:

Sub b()
Const PFAD$ = "C:\Users\Desktop\" 'anpassen
Const PRE$ = "Test - KW " 'anpassen
Const SUF$ = ".pdf" 'anpassen
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = Wb.ActiveSheet
Dim Mon, Verz$, DName$, i&
Mon = Array("Jänner", "Februar", "März", "April", "Mai", "Juni", "Juli", _
"August", "September", "Oktober", "November", "Dezember")
DName = Application.WorksheetFunction.WeekNum(Date, 21) & _
Format(Date, " - dddd, yyyy/mm.dd")
'Verzeichnis-Name aus aktuellem Jahr und Monatsnamen erstellen
Verz = Year(Date) & " " & Mon(Month(Date) - 1)
'Verzeichnis anlegen, wenn noch nicht vorhanden
If Dir(PFAD & Verz, vbDirectory) = "" Then MkDir PFAD & Verz
'Prüfen ob eine Datei mit diesem Namen schon existiert
'...wenn ja wird solange mit _# ergänzt (hochgezählt) bis der
'Dateiname noch nicht existiert, und mit dem letzten gespeichert
Do Until Dir(PFAD & Verz & "\" & PRE & DName & SUF) = ""
i = i + 1: DName = DName & "_" & i
Loop
'Blatt entsprechend speichern
Ws.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=PFAD & Verz & "\" & PRE & DName & SUF, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
MsgBox "PDF-Export abgeschlossen!"
Set Wb = Nothing: Set Ws = Nothing: Erase Mon
End Sub

LG
Michael

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

per Button in Ordner speichern

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread