マクロを使用してファイル名を定義する

Question

既存のExcelファイルからPDFファイルを保存するには、次のコードを使用します。

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 

コードを再帰的に実行する必要がありますので、私は、ファイル名にシートに所定のセル（B2）に含まれる週番号を、追加したいと思います。

私は

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

を交換しようとしたが、それは動作しません。エラーはどこですか？

Answer 1

FullNameプロパティはフルパス&ファイル名&拡張子を返します。 Cells(2,2)を追加すると"c:\path\to\filename.xlsx" & Cells(2,2).Valueのような値が得られます。

の前に、ファイル拡張部分のを挿入する必要があります。

あなたは、おそらくそのようなことを行うことができます。

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

または、FileSystemObjectオブジェクトを使用しない：

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

フルネームは、ファイル拡張子を含みます。おそらくこれ（B2へのシート参照を追加する方が良いでしょう）。

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

Answer 3

このような何かが（私は少しそれをクリーンアップ）それを行うだろう：

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