VBA печать в PDF и сохранение с автоматическим именем файла
У меня есть код, который печатает выбранную область на листе в PDF и позволяет пользователю выбрать папку и имя входного файла.
Есть две вещи, которые я хочу сделать, хотя:
- существует ли способ, которым PDF-файл может создать папку на рабочем столе пользователя и сохранить файл с именем файла, основанным на определенных ячейках листа?
- Если несколько копий одного и того же листа сохраняются/печатаются в 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
1 ответ:
Надеюсь, это достаточно понятно. Используйте комментарии в коде, чтобы понять, что происходит. Передайте этой функции одну ячейку. Значение этой ячейки будет базовым именем файла. Если ячейка содержит "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Где находится ваш код по отношению ко всему остальному? Возможно, вам нужно сделать модуль, если у вас его еще нет, и переместить ваш существующий код туда же.
Comments