Definieren Sie den Dateinamen über Makro

Question

Ich habe den folgenden Code zum Speichern einer PDF-Datei aus einer vorhandenen Excel-Datei.

Dim FSO As Object 
Dim s(1) As String 
Dim sNewFilePath As String 

Set FSO = CreateObject("Scripting.FileSystemObject") 
s(0) = ThisWorkbook.FullName 

If FSO.FileExists(s(0)) Then 
    '//Change Excel Extension to PDF extension in FilePath 
    s(1) = FSO.GetExtensionName(s(0)) 
    If s(1) <> "" Then 
     s(1) = "." & s(1) 
     sNewFilePath = Replace(s(0), s(1), ".pdf") 

     '//Export to PDF with new File Path 
     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF,_ 
     _ Filename:=sNewFilePath, Quality:=xlQualityStandard,_ 
     _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False 
    End If 
Else 
    '//Error: file path not found 
    MsgBox "Error: this workbook may be unsaved. Please save and try again." 
End If 

Set FSO = Nothing 

Da der Code rekursiv ausgeführt werden muss, würde ich würde an den Dateinamen die Wochennummer, enthalten in einer bestimmten Zelle (B2) in dem Blatt gerne hinzufügen.

versuchte ich

s(0) = ThisWorkbook.FullName & Cells(2,2) 

ersetzen, aber es funktioniert nicht. Wo ist der Fehler?

Answer 1

FullName Eigenschaft gibt den vollständigen Pfad zurück & Dateiname & Erweiterung. Wenn Sie Cells(2,2) anhängen, erhalten Sie einen Wert wie "c:\path\to\filename.xlsx" & Cells(2,2).Value.

Sie müssen die Wochennummer (Cells(2,2)) vor den Dateierweiterungsteil einfügen.

Sie können sich wahrscheinlich das tun, wie so:

sNewFilePath = Replace(s(0), s(1), Cells(2,2).Value & ".pdf") 

Oder ohne Filesystem mit:

Dim fullName As String, weekNum As String 
Dim sNewFilePath As String 

weekNum = Cells(2,2).Value 
fullName = ThisWorkbook.FullName 

'If the file exists, the `Dir` function will return the filename, len != 0 
If Len(Dir(fullName)) <> 0 Then 
    'remove the extension using Mid/InstrRev functions, _ 
    build the new filename with weeknumber & pdf extension 
    sNewFilePath = Mid(fullName, 1, InstrRev(fullName,".")-1) & weekNum & ".pdf" 
    'Export to PDF with new File Path 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF,_ 
     _ Filename:=sNewFilePath, Quality:=xlQualityStandard,_ 
     _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False 
    End If 
Else 
    '//Error: file path not found 
    MsgBox "Error: this workbook may be unsaved. Please save and try again." 
End If 

Answer 2

Fullname enthält die Dateierweiterung. Vielleicht (Sie wären besser dran, einen Blattbezug zu B2 hinzuzufügen).

s(0)=split(ThisWorkbook.FullName, ".")(0) & Cells(2, 2) & ".pdf" 

Answer 3

So etwas würde es tun (Ich reinigte es ein wenig nach oben):

Dim FSO As Object 
Dim s(1) As String 
Dim sNewFilePath As String 
Sub SavePDF() 

Set FSO = CreateObject("Scripting.FileSystemObject") 
s(0) = ThisWorkbook.FullName 

If FSO.FileExists(s(0)) Then 
    '//Change Excel Extension to PDF extension in FilePath 
    s(1) = FSO.GetExtensionName(s(0)) 
    If s(1) <> "" Then 
     s(1) = "." & s(1) 
     sNewFilePath = Left(s(0), InStrRev(s(0), "\")) & ".pdf" 

     '//Export to PDF with new File Path 
     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ 
     sNewFilePath & Sheets("wsTakeOff").Range("AY2").Value & " - " & Sheets("wsTakeOff").Range("D1") & ".pdf", Quality:= _ 
     xlQualityStandard, includedocproperties:=False, ignoreprintareas:=False, _ 
     openafterpublish:=False 
    End If 
Else 
    '//Error: file path not found 
    MsgBox "Error: this workbook may be unsaved. Please save and try again." 
End If 

Set FSO = Nothing 

End Sub