我有一个代码可以将工作表中的选定区域打印到PDF
,并允许用户选择文件夹和输入文件名。
我想做两件事:
这是我到目前为止的代码:
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
答案 0 :(得分:7)
希望这足够自我解释。使用代码中的注释来帮助了解发生的情况。将单个单元格传递给此函数。该单元格的值将是基本文件名。如果单元格包含&#34; AwesomeData&#34;然后我们将尝试在当前用户桌面中创建一个名为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包含字符串&#34; FileName&#34;没有引号。使用此子句来调用我的函数并保存了一个文件。
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
您的代码在哪里引用其他所有内容?如果您尚未创建模块,可能需要将现有代码移动到那里。