per Button in Ordner speichern
18.08.2017 07:46:00
harti
ich habe diesen Beitrag noch einmal in's Leben gerufen da ich den ursprünglichen Beitrag nicht mehr in der Liste finde.
Das u. a. Makro hat Michael (migre) gebastelt...und es hat mir super bei der Erstellung eines Projektes geholfen.
Leider muss ich da noch einmal nerven und um Hilfe bitten.
Das Makro speichert ja die PDFs in den Ordner nach folgender Syntax:
Test - KW 33 -Freitag, 2017.08.18mappe1.pdf
Test - KW 33 -Freitag, 2017.08.18_1mappe1.pdf
Test - KW 33 -Freitag, 2017.08.18_1_2mappe1.pdf
Test - KW 33 -Freitag, 2017.08.18_1_2_3mappe1.pdf
usw...
Wie müsste das Makro abgeändert werden damit die PDFs wie folgt abgespeichert werden:
Test - 2017.08.18_08:12.pdf
Test - 2017.08.18_11:21.pdf
Also mit der Uhrzeit der Speicherung anstatt der fortlaufenden Nummerierung..
Danke schon einmal für jegliche Hilfe.
harti
Hier das Makro:
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