web-dev-qa-db-fra.com

VBA Imprimer vers PDF et enregistrer avec le nom de fichier automatique

J'ai un code qui imprime une zone sélectionnée dans une feuille de calcul sur PDF et permet à l'utilisateur de sélectionner le dossier et de saisir le nom du fichier.

Je veux cependant faire deux choses:

  1. Existe-t-il un moyen pour que le fichier PDF PDF puisse créer un dossier sur le bureau des utilisateurs et enregistrer le fichier avec un nom de fichier basé sur des cellules spécifiques de la feuille?
  2. Si plusieurs copies de la même feuille sont enregistrées/imprimées dans PDF chaque copie peut-elle avoir un numéro, par exemple 2, 3 dans le nom de fichier en fonction du numéro de copie? **

Voici le code que j'ai jusqu'à présent:

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`

MISE À JOUR: J'ai changé le code et les références et cela fonctionne maintenant. J'ai lié le code à un bouton de commande sur la feuille de location -

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

Espérons que cela soit suffisamment explicite. Utilisez les commentaires dans le code pour comprendre ce qui se passe. Passez une seule cellule à cette fonction. La valeur de cette cellule sera le nom du fichier de base. Si la cellule contient "AwesomeData", nous essaierons de créer un fichier dans le bureau des utilisateurs actuels appelé AwesomeData.pdf. Si cela existe déjà, essayez AwesomeData2.pdf et ainsi de suite. Dans votre code, vous pouvez simplement remplacer les lignes filename = Application..... Par 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

Les lignes de débogage vous aideront à comprendre ce qui se passe si vous avez besoin de parcourir le code. Retirez-les comme bon vous semble. Je suis devenu un peu fou avec les variables mais c'était pour que ce soit aussi clair que possible.

En action

Ma cellule O1 contenait la chaîne "FileName" sans les guillemets. Utilisé ce sous pour appeler ma fonction et il a enregistré un fichier.

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

Où se trouve votre code par rapport à tout le reste? Vous devrez peut-être créer un module si vous ne l'avez pas déjà fait et y déplacer votre code existant.

9
Matt