web-dev-qa-db-ja.com

VBA Print PDFおよび自動ファイル名で保存

ワークシートの選択した領域をPDFに印刷し、ユーザーがフォルダーを選択してファイル名を入力できるようにするコードがあります。

ただし、私がやりたいことが2つあります。

  1. PDFファイルがユーザーのデスクトップにフォルダーを作成し、シート内の特定のセルに基づいたファイル名でファイルを保存する方法はありますか？
  2. 同じシートの複数のコピーをPDFに保存/印刷する場合、各コピーにはコピー番号に基づいてファイル名に2、3などの番号を付けることができますか？**

ここに私がこれまでに持っているコードがあります：

Sub PrintRentalForm()
Dim filename As String

Worksheets("Rental").Activate


filename = Application.GetSaveAsFilename(InitialFileName:="", _
                                     FileFilter:="PDF Files (*.pdf), *.pdf", _
                                     Title:="Select Path and Filename to save")

If filename <> "False" Then
With ActiveWorkbook
    .Worksheets("Rental").Range("A1:N24").ExportAsFixedFormat Type:=xlTypePDF, _
                                              filename:=filename, _
                                              Quality:=xlQualityStandard, _
                                              IncludeDocProperties:=True, _
                                              IgnorePrintAreas:=False, _
                                              OpenAfterPublish:=True
End With
End If


filename = Application.GetSaveAsFilename(InitialFileName:="", _
                                     FileFilter:="PDF Files (*.pdf), *.pdf", _
                                     Title:="Select Path and Filename to save")

If filename <> "False" Then
With ActiveWorkbook
    .Worksheets("RentalCalcs").Range("A1:N24").ExportAsFixedFormat Type:=xlTypePDF, _
                                              filename:=filename, _
                                              Quality:=xlQualityStandard, _
                                              IncludeDocProperties:=True, _
                                              IgnorePrintAreas:=False, _
                                              OpenAfterPublish:=False
End With
End If

End Sub`

更新：コードと参照を変更しましたが、現在は機能しています。レンタルシートのコマンドボタンにコードをリンクしました-

Private Sub CommandButton1_Click()
Dim filenamerental As String
Dim filenamerentalcalcs As String
Dim x As Integer


x = Range("C12").Value
Range("C12").Value = x + 1

Worksheets("Rental").Activate

Path = CreateObject("WScript.Shell").specialfolders("Desktop")

filenamerental = Path & "\" & Sheets("Rental").Range("O1")

'ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
Worksheets("Rental").Range("A1:N24").Select
Selection.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=filenamerental, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

Worksheets("RentalCalcs").Activate

Path = CreateObject("WScript.Shell").specialfolders("Desktop")

filenamerentalcalcs = Path & "\" & Sheets("RentalCalcs").Range("O1")

'ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
Worksheets("RentalCalcs").Range("A1:N24").Select
Selection.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=filenamerentalcalcs, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

Worksheets("Rental").Activate
Range("D4:E4").Select

End Sub
excelvbaexcel-vbapdfautosave
6
Preena

うまくいけば、これは十分に自明です。コード内のコメントを使用して、何が起こっているのかを理解してください。この関数に単一のセルを渡します。そのセルの値はベースファイル名になります。セルに「AwesomeData」が含まれている場合、現在のユーザーのデスクトップにAwesomeData.pdfというファイルを作成しようとします。既に存在する場合は、AwesomeData2.pdfなどを試してください。あなたのコードでは、行_filename = Application....._をfilename = GetFileName(Range("A1"))で置き換えることができます

_Function GetFileName(rngNamedCell As Range) As String
    Dim strSaveDirectory As String: strSaveDirectory = ""
    Dim strFileName As String: strFileName = ""
    Dim strTestPath As String: strTestPath = ""
    Dim strFileBaseName As String: strFileBaseName = ""
    Dim strFilePath As String: strFilePath = ""
    Dim intFileCounterIndex As Integer: intFileCounterIndex = 1

    ' Get the users desktop directory.
    strSaveDirectory = Environ("USERPROFILE") & "\Desktop\"
    Debug.Print "Saving to: " & strSaveDirectory

    ' Base file name
    strFileBaseName = Trim(rngNamedCell.Value)
    Debug.Print "File Name will contain: " & strFileBaseName

    ' Loop until we find a free file number
    Do
        If intFileCounterIndex > 1 Then
            ' Build test path base on current counter exists.
            strTestPath = strSaveDirectory & strFileBaseName & Trim(Str(intFileCounterIndex)) & ".pdf"
        Else
            ' Build test path base just on base name to see if it exists.
            strTestPath = strSaveDirectory & strFileBaseName & ".pdf"
        End If

        If (Dir(strTestPath) = "") Then
            ' This file path does not currently exist. Use that.
            strFileName = strTestPath
        Else
            ' Increase the counter as we have not found a free file yet.
            intFileCounterIndex = intFileCounterIndex + 1
        End If

    Loop Until strFileName <> ""

    ' Found useable filename
    Debug.Print "Free file name: " & strFileName
    GetFileName = strFileName

End Function
_

デバッグ行は、コードをステップスルーする必要がある場合に何が起こっているかを把握するのに役立ちます。必要に応じて削除してください。私は変数に少し夢中になりましたが、これをできるだけ明確にすることでした。

動作中

私のセルO1には、引用符なしの文字列「FileName」が含まれていました。このサブルーチンを使用して関数を呼び出し、ファイルを保存しました。

_Sub Testing()
    Dim filename As String: filename = GetFileName(Range("o1"))

    ActiveWorkbook.Worksheets("Sheet1").Range("A1:N24").ExportAsFixedFormat Type:=xlTypePDF, _
                                              filename:=filename, _
                                              Quality:=xlQualityStandard, _
                                              IncludeDocProperties:=True, _
                                              IgnorePrintAreas:=False, _
                                              OpenAfterPublish:=False
End Sub
_

他のすべてを参照して、コードはどこにありますか？おそらく、まだモジュールを作成しておらず、既存のコードをそこに移動する必要がある場合があります。

9
Matt