I currently have a VBScript that exports an entire excel worksheet to a PDF. I was wondering if it would be possible to set the script to only export the selected areas. I know this can be done manually, but I've been tasked with automating this process. If achieved, it would make the whole reporting proccess a lot easier. The VBScript that I'm currently using is:
Sub PDFActiveSheet()
Dim ws As Worksheet
Dim strPath As String
Dim myFile As Variant
Dim strFile As String
On Error GoTo errHandler
Set ws = ActiveSheet
'enter name and select folder for file
' start in current workbook folder
strFile = Replace(Replace(ws.Name, " ", ""), ".", "_") _
& "_" _
& Format(Now(), "yyyymmdd\_hhmm") _
& ".pdf"
strFile = ThisWorkbook.Path & "\" & strFile
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If myFile <> "False" Then
ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox "PDF version of report has been created."
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
I've already tried replacing the "Set ws = ActiveSheet" to "Selection", and that has yielded no results. Also, as a side note, when selections are sent to a PDF, they appear on separate sheets.Is it possible to put them both on one sheet?
Thanks in advance for any help that you can offer me.
Try setting the Print Area that you want to output to PDF.
Related
I am trying to create a macro that will generate separate PDF files for Selected Worksheets in a Workbook. I found this code on line, which works great, it puts all selected sheets in ONE PDF. I need to have each selected sheet as a separate PDF.
I am a beginner to VBA.
Sub PDFActiveSheet()
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
Separate sheets to separate PDF files
Sub ExportToPDFs()
' PDF Export Macro
' Change C:\Exports\ to your folder path where you need the diles saved
' Save Each Worksheet to a separate PDF file.
Dim ws As Worksheet
For Each ws In Worksheets
ws.Select
nm = ws.Name
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:="C:\Users\Excel\Desktop\test\" & nm & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Next ws
End Sub
I have set up a command button to save the current worksheet as a PDF file. I have played around with this code for several hours and almost got it to work properly but it seems I have disconnected some areas and cannot find my way back. Please see below for the code that I am using and the variables I am having an issue with at this point. Any help or information would be much appreciated! Thanks in advance!
Issues:
When you click 'Cancel' in the save application box, the document still tries to save.
If the file already exists:
Selecting 'Yes' to over-write does not save the document.
Selecting 'No' to over-write and renaming as another already existing document does not prompt another Question box to over-write or not. It simply over-writes the original document name.
Sub PDFFHA()
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strPath = "I:\OCC FRB REMIC Reporting\Quality Control\PDFs"
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
strName = Replace(wsA.Range("D3"), " ", "")
strName = Replace(strName, ".", "_")
strFile = "FHA" & "_" & strName & "_" & "QC" & ".pdf"
strPathFile = strPath & strFile
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If bFileExists(strPathFile) Then
lOver = MsgBox("Overwrite existing file?", _
vbQuestion + vbYesNo, "File Exists")
If lOver <> vbYes Then
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strPathFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox "PDF file has been created: " _
& vbCrLf _
& strPathFile
Else
GoTo exitHandler
End If
End If
Else
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strPathFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox "PDF file has been created: " _
& vbCrLf _
& strPathFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
'=============================
Function bFileExists(rsFullPath As String) As Boolean
bFileExists = CBool(Len(Dir$(rsFullPath)) > 0)
End Function
'=============================
With some clean-up and re-formatting.
If the file already exists, you are prompted to overwrite or not. The code only checks for the response to be vbNo since vbYes implies that strPathFile remains the same, i.e. no action needed. The loop handles a Cancel click, as well as the possibility that your new strPathFile is again an existing file.
Option Explicit
Sub PDF_FHA()
Dim wsA As Worksheet: Set wsA = ActiveWorkbook.ActiveSheet
Dim strName, strPath, strFile, strPathFile As String
On Error GoTo errHandler
' Get path
strPath = "I:\OCC FRB REMIC Reporting\Quality Control\PDFs\"
' Get and clean filename
strName = Replace(wsA.Range("D3"), " ", "")
strName = Replace(strName, ".", "_")
strFile = "FHA_" & strName & "_QC.pdf"
strPathFile = strPath & strFile
' Check if file exists, prompt overwrite
If bFileExists(strPathFile) Then
If MsgBox("Overwrite existing file?", _
vbQuestion + vbYesNo, "File Exists") = vbNo Then
Do
strPathFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
' Handle cancel
If strPathFile = "False" Then Exit Sub
' Loop if new filename still exists
Loop While bFileExists(strPathFile)
End If
End If
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strPathFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox "PDF file has been created: " _
& vbCrLf _
& strPathFile
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
End Sub
'=============================
Function bFileExists(rsFullPath As String) As Boolean
bFileExists = CBool(Len(Dir$(rsFullPath)) > 0)
End Function
'=============================
Firstly, turn Option Explicit on.
Follow the logic in If lOver <> vbYes Then. With the proper indenting you will see that it only handles the <> vbYes path and does not have an Else.
So, you do not actually handle the "Yes" case.
Your "No" logic only brings up a file dialog box and we don't know what you have done to test this (cancel, put new name in, just accept name as presented?). However, there is no additional question on this logic path. If you don't hit "Cancel" to the file dialog it will just save the file.
I'm trying to solve a situation where I have a range of text that can vary considerably depending on the results returned by an array formula. Sometimes there may be 5 rows of data, other times there may be 2000.
I think I've found the chunks of individual VBA codes required for each stage of the task I want to complete, but I am a complete novice with VBA and I have no idea how to piece these together.
The following selects all the actual data on the page, and excludes any rows that contain a hidden formula:
Sub PickedActualUsedRange()
Range("A1").Resize(Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column).Select
End Sub
So far so good. This is the exact range I want to print.
I also want the row height to be adjusted automatically, as each cell may contain a string of text of varying lengths that may be wrapped. So again the following command needs to go in:
Selection.Rows.AutoFit
Not too much trouble so far.
However, for the next bit I would like the VBA to use the selection made above, and to set this as the new print range. However, the code I have found seems to require me to set an absolute range (as per below), whereas I need this to adjust in accordance to the first selection
Selection.PageSetup.PrintArea = "$A$1:$B$12"
Once this is in place, the next step I would like to incorporate is this code I found via from the contextures website for printing the current worksheet:
Sub PDFActiveSheet()
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
Is anybody able to help me incorporate all of the above in to a single string of code please?
FURTHER EDIT
Still not sure what I'm doing with different chunks of code. What would be the exact text I would need to enter in Module1? I don't understand how to structure it:
'Function to give the actual data range from a given worksheet
Function PickedActualUsedRange(ws As Worksheet) As Range
Set PickedActualUsedRange = ws.Range("A1").Resize(Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
End Function
Sub PDFSheet(wsA As Worksheet) '<-- the sheet in question will be given as parameter
' Drop or change the following lines...
' Dim wsA As Worksheet '<-- drop
' Dim wbA As Workbook '<-- drop
...
strPath = wsA.Parent.Path ' <-- change
...
End Sub
Sub mySyb()
Sub PDFActiveSheet()
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
End Sub
Sub mySyb()
Dim ws As Worksheet: Set ws = Worksheets("report")
Dim r As Range: Set r = PickedActualUsedRange(ws)
r.Rows.AutoFit
ws.PageSetup.PrintArea = r.Address
PDFSheet (ws)
End Sub
To fit it the easiest way with your current code, here's how you would setup the print area:
ActiveSheet.PageSetup.PrintArea = Selection.address
And you can call your routines in order
PickedActualUsedRange
Selection.Rows.AutoFit
ActiveSheet.PageSetup.PrintArea = Selection.address
PDFActiveSheet
On a final note, your code uses unqualified ranges and counts a lot on Select, Selection, ActivateSheet etc... which is usually considered bad practice (code will be difficult to maintain). You'd better change it to get rid of these and use explicit sheet names and qualified ranges.
EDIT
' Function to give the actual data range from a given worksheet
Function PickedActualUsedRange(ws as Worksheet) as Range
Set PickedActualUsedRange = ws.Range("A1").Resize(ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
ws.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
End Function
Sub PDFSheet(wsA As Worksheet)
'www.contextures.com
'for Excel 2010 and later
Dim strTime As String, strName As String, strPath As String, strFile As String, strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wsA.Parent.Path & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
Sub myMacro
Dim ws as worksheet: Set ws = Worksheets("report")
Dim r as range: Set r = PickedActualUsedRange(ws)
r.Rows.AutoFit
ws.PageSetup.PrintArea = r.address
PDFSheet ws
End Sub
Put all this in a code module (i.e. Module1) and call the myMacro through ALT
+ F8
How can I get excel to automatically select save through VBA without manually clicking it. E.g- I have Code which selects each value on a Data Validation list and gets me to the stage below, although I have to click save each time.
I have tried adding in:
Application.EnableEvents = True
But it still only takes me to the stage on the image.
Sub PDFActiveSheet()
Dim ws As Worksheet
Dim strPath As String
Dim myFile As Variant
Dim strFile As String
On Error GoTo errHandler
Set ws = ActiveSheet
'enter name and select folder for file
' start in current workbook folder
strFile = Cells.Range("B1") & " Period " & Cells.Range("J1")
strFile = ThisWorkbook.Path & "\" & strFile
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If myFile <> "False" Then
ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False, _
From:=1, _
To:=2
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
To avoid prompting:
Sub PDFActiveSheet()
Dim ws As Worksheet
Dim strPath As String
Dim myFile As Variant
Dim strFile As String
On Error GoTo errHandler
Set ws = ActiveSheet
'enter name and select folder for file
' start in current workbook folder
strFile = Cells.Range("B1") & " Period " & Cells.Range("J1")
strFile = ThisWorkbook.Path & "\" & strFile & ".PDF"
ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False, _
From:=1, _
To:=2
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
Sub printPdf()
Dim strPath As String
Dim myFile As Variant
Dim strFile As String
'On Error GoTo errHandler
Set ws = Application.ActiveSheet
'enter name and select folder for file
' start in current workbook folder
strFile = Replace(Replace(ws.Name, " ", "_"), ".", "_") _
& ".pdf"
strfolder = ThisWorkbook.Path & "\myPdfFiles"
If Len(Dir(strfolder, vbDirectory)) = 0 Then
MkDir (strfolder)
End If
strFile = strfolder & "\" & strFile
ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Call closews
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file " & Err & ": " & Error(Err)
Resume exitHandler
End Sub
I am having an issue with saving the pdf files.
If the file already exists in the folder and has some changes made to it the macro will crash with the debugger pointing at the openAfterPulish line and display the following runtime error.
-2214701887(80071779)
"Document not saved."
My goal is that excel should automatically overwrite the old files. Excel will prompt me if I want to overwrite the file when I am saving it manually but crashes when I run the above code.
Check if it exists and delete it. In you VBA IDE go to the tools menu and selecte references. Select "Microsoft scripting runtime"
Dim Response As Integer
Dim fs As FileSystemObject
'We can come back to here after an error.
TryAgain:
If fs.FileExists(strFile) = True Then
On Error Goto DeleteError
fs.DeleteFile(strFile, True)
End If
DeleteError:
Response = MsgBox("Error deleting file. Do you have it open? Try again?", vbYesNo)
' If statement to check if the yes button was selected.
If Response = vbYes Then
Goto TryAgain
Else
Exit sub
End If
On Error Goto 0
ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Call closews