VBA打印到PDF并使用自动文件名保存

我有一个代码,打印工作表中的选定区域为PDF并允许用户select文件夹和input文件名。

有两件事我想要做:

  1. 有没有办法使PDF文件可以在用户桌面上创build一个文件夹,并根据表格中特定的单元格保存文件名?
  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` 

更新:我已经改变了代码和引用,现在它的作品。 我已经将代码链接到租赁表上的一个commandbutton –

 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 

希望这是不言自明的。 使用代码中的注释来帮助理解正在发生的事情。 将单个单元格传递给此函数。 该单元格的值将是基本文件名称。 如果单元格包含“AwesomeData”,那么我们将尝试在当前用户桌面中创build一个名为AwesomeData.pdf的文件。 如果已经存在,请尝试AwesomeData2.pdf等。 在你的代码中,你可以直接replacefilename = Application..... with 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 

debugging行将帮助您找出发生了什么,如果你需要一步一步通过代码。 如果您觉得合适,请将其移除。 我对这些变数有点疯狂,但是要尽可能地让这个变得清晰。

在行动

我的单元格O1包含不带引号的string“FileName”。 使用这个子调用我的function,它保存了一个文件。

 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 

您的代码位于其他所有位置的哪个位置? 也许你需要创build一个模块,如果你还没有移动现有的代码到那里。