Modify created macro to print array of sheets instead of Activesheet - excel

I have a Macro that i have managed to put together (its rough, and im new to VBA but it does what i want - for the most part) It currently prints the active sheet to PDF and names it based on cell values. I want to adapt this to print 2 sheets into a single file (if its separate files, thats more than ok!) The cell Value naming bit can be changed at the top which i can do, but its calling for the export to pdf bit that im having an issue with.
I have tried reading up on the Activeworkbook functions but im not having much luck. I have tried calling for a sheet array, but it doesnt like the exportasfixedformat Type:= and im kind of new to that part too. It likes it in the original code, but not when i try and change the ActiveWorkbook.ActiveSheet, it spits it.
It would finalise my calculator :) Any help would be greatly appreciated.
Code:
Sub GetFilePath_Click()
Dim FileAndLocation As Variant
Dim strFilename As String
strFilename = Sheets("Leave Loading").Range("F13") & ", " & Sheets("Leave Loading").Range("F12") & " - " & Sheets("Leave Loading").Range("F14") & "- " & "Leave Loading" & ".pdf"
FileAndLocation = Application.GetSaveAsFilename _
(InitialFileName:=strPathLocation & strFilename, _
filefilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select a Location to Save")
ActiveWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFilename, OpenAfterPublish:=True
End Sub
Thank you in advance!

Option Explicit
Sub GetFilePath_Click()
Dim FileAndLocation As Variant
Dim strFilename As String, strPathLocation As String
strPathLocation = ""
With Sheets("Leave Loading")
strFilename = .Range("F13") & ", " & .Range("F12") & " - " _
& .Range("F14") & "- Leave Loading" & ".pdf"
End With
FileAndLocation = Application.GetSaveAsFilename _
(InitialFileName:=strPathLocation & strFilename, _
filefilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select a Location to Save")
Sheets(Array("Sheet2", "Sheet4")).Select
Sheets("Sheet2").Activate
ActiveWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFilename, OpenAfterPublish:=True
End Sub

Related

VBA Excel - Export PDF file from Excel with second page

Just want to ask if how can I export a PDF file with vba? The thing is I do have a 10-F and 10-B sheet. The code below is working in the 10-F sheet. My problem is how can I export the data in the 10-B sheet together with the 10-F? The first page is the data in 10-F while the data in 10-B will be on the second page.
The range for the 10-B sheet is "B10:AD92".
Sub Ver_PDF()
'Create and assign variables
Dim saveLocation As String
Dim rng As Range
lname = ThisWorkbook.Sheets("HOME").Range("K12")
fname = ThisWorkbook.Sheets("HOME").Range("K13")
Name = fname & " " & lname
pdfile = "V-" & Name & ".pdf"
saveLocation = ThisWorkbook.Path & "\V-PDF\" & pdfile
Set rng = Sheets("10-F").Range("B9:AD89")
Dim strFileExists As String
strFileExists = Dir(saveLocation)
If strFileExists <> "" Then
Dim Ret
'~~> Change this to the relevant file path and name
Ret = IsFileOpen(saveLocation)
If Ret = True Then
MsgBox "Please close the PDF file before proceeding...", vbCritical + vbOKOnly, "Error"
Exit Sub
End If
End If
rng.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=saveLocation, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub
Any help is highly appreciated! Thanks!
This code will do what you want. Change the worksheet names in the array as well as the destination path and file name.
Sub ExportAsPDF()
Dim FolderPath As String
Dim FileName As String
FolderPath = "D:\Test PDFs\" ' change to suit: end on back-slash
FileName = "Test" ' change to suit
On Error Resume Next
MkDir FolderPath
On Error GoTo 0
Worksheets(Array("10-F", "10-B")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=FolderPath & FileName & ".PDF", _
OpenAfterPublish:=True, _
IgnorePrintAreas:=False
MsgBox "PDF was successfully created."
Worksheets(1).Select
End Sub
Change OpenAfterPublish to False if you don't want to see the result right away.

Run Time Error 5 - when saving to shared drive

My code runs perfectly when I save to my local drive, but when I save to the shared drive I get Runtime Error 5? How is this occurring?
I have unmerged cells and put it as center across selection
Ensured that the whole document is within the print margins
Edit: I have tried saving into the folder directory above where I was saving and it works. I understand that there is a character limit (pathname and title), which might be the problem? Is there a way to solve this?
The error is in the following area:
'Creating Only the PDF based on Company Network - there is an existing folder
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Fldr & "\" & Title & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False
This is the whole code:
Option Explicit
Private Function selectfolder()
'Defining the Variables
Dim user_name As String
user_name = Environ("username") 'to pick up the username from work environment
'Prompt for folder creation
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder to save"
.InitialFileName = "C:\Users\" & user_name & "\Department\"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Function 'if user does not press OK, end the function'
selectfolder = .SelectedItems(1)
End With
End Function
Sub SaveActiveSheetAsPDF()
'Create a message box to ask user before proceeding
If MsgBox("This will print to PDFs. Continue?", vbYesNo + vbQuestion + vbDefaultButton2, "Printing to PDFs") = vbNo Then Exit Sub
'Defining the Type of Variables
Dim inputrange As Range 'Range represents a cell or multiple cells in Excel
Dim cell As Range
Dim network, Address, Fldr, Title As String
'If user does not choose a folder
Address = selectfolder
If Address = "" Then
Exit Sub
End If
'Determine (set) where validation comes from - create a reference point
Set inputrange = Evaluate(Range("G2").Validation.Formula1)
For Each cell In inputrange
Range("G2").Value = cell.Value
'Defining the Company Network Folder variables
network = Range("C6").Value
Fldr = Address & "\" & network
Title = "MonthlyReport (" & Format(Range("C8"), "mmmm") & ") - " & ActiveSheet.Range("B2").Value & " (" & ActiveSheet.Range("G2").Value & ")"
'Creating the folder based on Company Network - No existing folder
If Dir(Fldr, vbDirectory) = "" Then
'Create a folder
MkDir Fldr
'Save Active Sheet as PDF and to Company Network file
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Fldr & "\" & Title & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False
'Creating Only the PDF based on Company Network - there is an existing folder
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Fldr & "\" & Title & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False
End If
Next cell
'Create a message box at end of task to inform user it is complete
MsgBox "Generation of PDF Reports and Folders Completed", vbInformation, "Complete"
End Sub
It is difficult to diagnose problems with network drive without more information, but I could suggest a workaround instead.
You could save the file on your local drive and then move it using the File System Object in VBA. Here's how it would look like:
'Save Active Sheet as PDF in temporary folder
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Environ("TEMP") & "\" & Title & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False
'Move PDF to Company network drive
Dim fso As FileSystemObject
Set fso = New FileSystemObject
fso.MoveFile Environ("TEMP") & "\" & Title & ".pdf", Fldr & "\" & Title & ".pdf"
Note that for this code to work, you need a reference to the Microsoft Scripting Runtime Library.

Problem with VBA print to pdf error code in windows 10 environment

I have code which works fine in windows 7 and other windows version environments, but when some of the users have been upgraded to Windows 10 (myself included)
This is a macro enabled sheet which has worked fine for 3 years, and as far as I can tell the only change is the 'upgrade' to windows 10!
this is the bit of code which seems to fail:
'saveas function for pdf
ws.range("A1:K69").ExportAsFixedFormat Type:=xlTypePDf, _
filename:=path & fname, _
Quality:-xlqualityStandard, _
IncludeDocProperties:=True' _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
I get a Run-Time error Method 'ExportAsFixedFormat' of Object 'Range' failed. But when someone in an earlier windows environment runs the code it works perfectly and I get the pdf created, saved and opened for the user to insert other documents into.
Driving me mental, and I cannot work out why this would fail - and also sporadically as well.
I use the below to auto save an excel sheet as PDF, should try and save it to the excel file location and name it after the tab name.
If you set a print area on the sheet for the range you want to view in the PDF first, it should work :)
Hope it helps
Sub Export_Summary()
'
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
'user 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

Define file name via macro

I have the following piece of code to save a pdf file from an existing excel file.
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
s(0) = ThisWorkbook.FullName
If FSO.FileExists(s(0)) Then
'//Change Excel Extension to PDF extension in FilePath
s(1) = FSO.GetExtensionName(s(0))
If s(1) <> "" Then
s(1) = "." & s(1)
sNewFilePath = Replace(s(0), s(1), ".pdf")
'//Export to PDF with new File Path
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF,_
_ Filename:=sNewFilePath, Quality:=xlQualityStandard,_
_ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Else
'//Error: file path not found
MsgBox "Error: this workbook may be unsaved. Please save and try again."
End If
Set FSO = Nothing
Since the code has to be run recursively, I'd would like add to the file name the week number, contained in a given cell (B2) in the sheet.
I tried replacing
s(0) = ThisWorkbook.FullName & Cells(2,2)
but it is not working. Where is the error?
FullName property returns the full path & filename & extension. Appending Cells(2,2) to that will give you a value like "c:\path\to\filename.xlsx" & Cells(2,2).Value.
You need to insert the week number (Cells(2,2)) before the file extension part.
You can probably do that like so:
sNewFilePath = Replace(s(0), s(1), Cells(2,2).Value & ".pdf")
Or, without using FileSystemObject:
Dim fullName As String, weekNum As String
Dim sNewFilePath As String
weekNum = Cells(2,2).Value
fullName = ThisWorkbook.FullName
'If the file exists, the `Dir` function will return the filename, len != 0
If Len(Dir(fullName)) <> 0 Then
'remove the extension using Mid/InstrRev functions, _
build the new filename with weeknumber & pdf extension
sNewFilePath = Mid(fullName, 1, InstrRev(fullName,".")-1) & weekNum & ".pdf"
'Export to PDF with new File Path
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF,_
_ Filename:=sNewFilePath, Quality:=xlQualityStandard,_
_ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Else
'//Error: file path not found
MsgBox "Error: this workbook may be unsaved. Please save and try again."
End If
FullName includes the file extension. Perhaps this (you would be better off adding a sheet reference to B2 also).
s(0)=split(ThisWorkbook.FullName, ".")(0) & Cells(2, 2) & ".pdf"
Something like this would do it (I cleaned it up a little bit):
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String
Sub SavePDF()
Set FSO = CreateObject("Scripting.FileSystemObject")
s(0) = ThisWorkbook.FullName
If FSO.FileExists(s(0)) Then
'//Change Excel Extension to PDF extension in FilePath
s(1) = FSO.GetExtensionName(s(0))
If s(1) <> "" Then
s(1) = "." & s(1)
sNewFilePath = Left(s(0), InStrRev(s(0), "\")) & ".pdf"
'//Export to PDF with new File Path
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
sNewFilePath & Sheets("wsTakeOff").Range("AY2").Value & " - " & Sheets("wsTakeOff").Range("D1") & ".pdf", Quality:= _
xlQualityStandard, includedocproperties:=False, ignoreprintareas:=False, _
openafterpublish:=False
End If
Else
'//Error: file path not found
MsgBox "Error: this workbook may be unsaved. Please save and try again."
End If
Set FSO = Nothing
End Sub

save pdf as cell name with multiple cells

I am trying to save a pdf with the name being info in a cell, but the name involves multiple cells. the cells have formulas inputted because they pull from a seperate sheet in my spreadsheet. how would i could about doing this? this is the formulas in the cells that i want to pull the name for the pdf from:
=VLOOKUP('Work Order'!F26,'Fort McMurray File Services'!A2:AJ1515,6,FALSE)
=VLOOKUP('Work Order'!F26,'Fort McMurray File Services'!A2:AJ1515,6,FALSE)
And this is the code i am using in vba:
Private Sub filename_cellvalue()
'Update 20141112
Dim Path As String
Dim filename As String
Path = "C:\Users\meghan lewis\Desktop\MASS DEMO"
filename = .Range("C7").Value & .Range("D7").Value & _
.Range("E7").Value & .Range("F7").Value & _
.Range("G7").Value & .Range("H7").Value & .Range("I7").Value
ActiveWorkbook.SaveAs filename:=Path & filename & ".PDF", FileFormat:=xlNormal
End Sub
Sub SaveAsPDF()
Dim fName As String
With Worksheets("WORK ORDER")
fName = .Range("C7").Value & .Range("D7").Value & _
.Range("E7").Value & .Range("F7").Value & _
.Range("G7").Value & .Range("H7").Value & _
.Range("I7").Value
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:= _
"C:\Users\meghan lewis\Desktop\MASS DEMO & fName", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub
When I try to save it saves the pdf as mass demo rather than pulling from the cells. Please advise.
How does your code even compile? You have unqualified range addresses like .Range("C7").Value, .Range("D7").Value etc in Sub filename_cellvalue
In Sub SaveAsPDF(), change "C:\Users\meghan lewis\Desktop\MASS DEMO & fName" to "C:\Users\meghan lewis\Desktop\MASS DEMO" & fName
fname within quotes will behave as a String and not a variable.

Resources