Fehler im Code beim speichern
25.02.2020 14:43:19
Ludger
Dieser Code funktioniert eigentlich ganz gut, aber es gibt ein kleines Problem.
Das Problem ist das zwar ein Unterordner erstellt wird, aber die Datei nicht darin gespeichert werden, sondern außerhalb des Ordners.
Option Explicit
Sub PrüfenAnlegenPDFspeichern()
Dim Pfad As String
Dim Ordner As String
Dim Datei As String
Dim Endpfad As String
With Sheets("PDF")
Ordner = .Cells(1, 2).Value & "_" 'Namen der Unterordner
Datei = "Sonderfahrtabrechnung_" & .Cells(12, 7).Value & "_" & .Cells(5, 7).Value & ".pdf" ' Dateiname PDF
End With
Pfad = "E:\Ludger\Documents\Exel_Test\Sonderfahrten\" & Ordner 'Grundpfad
If Dir(Pfad, vbDirectory) = Ordner Then
MsgBox "Das Verzeichnis existiert bereits!"
Else
Call MakeDir(Pfad)
MsgBox "Verzeichnis erstellt."
End If
Endpfad = Pfad & Datei
MsgBox "Verzeichnis " & Endpfad
'Sheets(Array("Deckblatt Q-Fähigk ", "Proz-BalkenMatrix", "Bewertungsmatrix", _
'"QTP dt.", "Maßnahmenplan")).Select
Sheets("PDF").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Endpfad, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub
Private Function MakeDir(FolderName As String)
Dim S As Variant, i As Long, F As String
S = Split(FolderName, "\")
For i = LBound(S) To UBound(S)
If S(i) "" Then
F = F & S(i) & "\"
On Error Resume Next
MkDir F
On Error GoTo 0
End If
Next i
End Function
Lieben Gruß Ludger