I'm new in Excel macros. I try to make a "save as pdf" button. I wrote a code like this:
Sub save_as_pdf()
'
' save_as_pdf Macro
' Saves sheet as PDF
'
Dim Path As String
Dim filename As String
Path = "/Users/Adrian/Desktop/"
filename = ThisWorkbook.Sheets("Controller").Range("B20")
PathAndFilename = Path & filename & ".pdf"
MsgBox "Saved file as: " & PathAndFilename
Sheets("View").Select
Application.DisplayAlerts = False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:= _
PathAndFilename, Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Application.DisplayAlerts = True
End Sub
I need the Range("B20") because I keep there a filename based on some in-excel logic.
The MsgBox produces a valid path and filename.
Yet, when I run this I get a "Error while printing" and a "Runtime error 1004" highlighting ActiveSheet.ExportAsFixedFormat ...
Set a print area in the sheet to export.
Also verify path as I expected \ and a drive letter e.g. C:\
The following works for me
Option Explicit
Sub save_as_pdf()
Dim Path As String
Dim filename As String
Dim PathAndFileName As String
Path = "C:\Users\User\Desktop\" ' "C:\Users\Adrian\Desktop\"
filename = ThisWorkbook.Sheets("Controller").Range("B20")
PathAndFileName = Path & filename & ".pdf"
MsgBox "Saved file as: " & PathAndFileName
Sheets("View").Select
Application.DisplayAlerts = False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:= _
PathAndFileName, Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Application.DisplayAlerts = True
End Sub
Related
I have a work book that has many macros to export various worksheets as pdfs in the same location the workbook is saved.
My issue is, if the workbook is saved in a folder on the desktop, then the PDFs are generated just fine.
When the workbook is saved on a network location, the pdfs don't generate. below is a sample of the macro:
Sub PDF_CStmtP()
Application.ScreenUpdating = False
ThisWorkbook.Sheets(Array("C Stmt - P")).Select
pdfname = fileSaveName
ChDir ActiveWorkbook.Path & "\"
fileSaveName = "Closing Statement (Purchase)"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
fileSaveName _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Application.ScreenUpdating = True
ActiveWorkbook.Sheets("Main Menu").Activate
MsgBox "File Saved " & " " & fileSaveName
End Sub
Your issue is the ChDir command, see here for an explanation: https://www.techonthenet.com/excel/formulas/chdir.php
The important part of this is "The CHDIR statement lets you change the current directory on the current drive. If you need to change drives, try using the CHDRIVE statement first."
When you are trying to save to a network drive you are changing the drive letter from C:\ to whatever the network drive is mapped to, in my case it was U:\ .
The simple fix to your code is to move the Path from ChDir to just being in the filename, so your code should look like:
Sub PDF_CStmtP()
Application.ScreenUpdating = False
ThisWorkbook.Sheets(Array("C Stmt - P")).Select
pdfname = fileSaveName
'ChDir ActiveWorkbook.Path & "\"
fileSaveName = ActiveWorkbook.Path & "\" & "Closing Statement (Purchase)"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= fileSaveName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Application.ScreenUpdating = True
ActiveWorkbook.Sheets("Main Menu").Activate
MsgBox "File Saved " & " " & fileSaveName
End Sub
There are a few other edits you could make to clean it up, but this will solve the issue at hand.
**Based on the comment about the message box, you could change the code to this:
Sub PDF_CStmtP()
Application.ScreenUpdating = False
ThisWorkbook.Sheets(Array("C Stmt - P")).Select
pdfname = "Closing Statement (Purchase)"
'ChDir ActiveWorkbook.Path & "\"
fileSaveName = ActiveWorkbook.Path & "\" & pdfname
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= fileSaveName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Application.ScreenUpdating = True
ActiveWorkbook.Sheets("Main Menu").Activate
MsgBox "File Saved " & " " & pdfname
End Sub
I am printing worksheets to one single PDF file with one chunk of code. With this PDF file open, If I attempt another print to PDF from this same excel file I get a VB error: "Document not saved" and debug takes me here in the code:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:= _
strFilename & " " & wedate_text & " Time", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
HERE IS CODE:
Sub PrintAnadarkoTicketsToPDF()
Worksheets("Cover").Visible = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Dim strFilename As String
Dim rngRange As Range
Dim wedate As Date
Dim wedate_text As String
Set rngRange = Worksheets("Cover").Range("A5")
strFilename = rngRange.Value
wedate = Worksheets("Cover").Range("B24").Value
wedate_text = Format$(wedate, "mm.dd.yyyy")
Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
If Sheets(i).Visible = True Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If
Next i
Sheets(myArray).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:= _
strFilename & " " & wedate_text & " Time", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
Worksheets("Cover").Visible = True
Sheets(1).Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
End Sub
My question is: How do I print this second PDF without crashing the script? I would like to close the previous PDF or create the second PDF with a different file name. Thanks for the suggestions.
Randy
I'm not sure why you want to have a loop that counts the number of non-hidden sheets. Plus, you could export the sheets inside that loop. That may fix your issue:
For i = 1 To Sheets.Count
If Sheets(i).Visible = True Then
Sheets(i).ExportAsFixedFormat Type:=xlTypePDF, filename:= _
strFilename & Trim(Str(i)) & " " & wedate_text & " Time", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
End If
Next i
Note also the addition of the workbook number to the file name, because it's trying to save to the same file.
I have code that selects an array of sheets to be printed to a pdf document, however I am trying to implement a user form with a series of check boxes that correspond to a specific sheets.
The following code selects a predetermined array of sheets and prints them as a pdf
Sub PDFAllSheets_Click()
Dim ws As Worksheet
Dim strPath As String
Dim myfile As Variant
Dim strFile As String
Dim sheetstoprint As String
On Error GoTo errHandler
Set ws = ActiveSheet
strFile = "E_CALC_" & Worksheets("Contents").Range("H7").Text & ".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
ThisWorkbook.Sheets(Array("Engine", "CHP Layout", "Ventilation", "Exhaust", "Gas", "Hazardous Zoning", "Gas Ramp up", "Steam Boilers", _
"JW PU", "AC PU", "Combustion", "BREEAM NOx", "Pump P1", "Pump P2", "Pump P3", "Pump P4", "Pump P5")).Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=myfile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
MsgBox "PDF file has been created."
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file", vbRetryCancel, "Oops!"
Resume exitHandler
End Sub
I need the following UserForm's check boxes to define the sheets to include in the array.
UserForm1
If you have a UserForm with a ListBox and a CommandButton, this should work, assuming you have sheets named as you specified.
This code should of course be added to the UserForm code module.
Private Sub CommandButton1_Click()
Dim SheetArray() As Variant
Dim indx As Integer
Dim ws As Worksheet
Dim strPath As String
Dim myfile As Variant
Dim strFile As String
Dim sheetstoprint As String
On Error GoTo errHandler
Set ws = ActiveSheet
strFile = "E_CALC_" & Worksheets("Contents").Range("H7").Text & ".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
Application.ScreenUpdating = False
Application.DisplayAlerts = False
indx = 0
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
ReDim Preserve SheetArray(indx)
SheetArray(indx) = Sheets(ListBox1.List(i, 1)).Index
indx = indx + 1
End If
Next i
If indx > 0 Then
Sheets(SheetArray()).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=myfile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
'.ExportAsFixedFormat Type:=xlTypePDF, Filename:=myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End If
End If
exitHandler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
errHandler:
MsgBox "Could not create PDF file", vbRetryCancel, "Oops!"
Resume exitHandler
End Sub
Private Sub UserForm_Initialize()
Dim wks() As Variant
wks = Array("Engine", "CHP Layout", "Ventilation", "Exhaust", "Gas", "Hazardous Zoning", "Gas Ramp up", "Steam Boilers", _
"JW PU", "AC PU", "Combustion", "BREEAM NOx", "Pump P1", "Pump P2", "Pump P3", "Pump P4", "Pump P5")
'Debug.Print wks(16)
For i = 0 To UBound(wks)
ListBox1.AddItem wks(i)
ListBox1.List(ListBox1.ListCount - 1, 1) = wks(i)
Next i
End Sub
Remember to allow listbox multiselect in the listbox properties window.
Edit:
During my testing, it seems that the Excel application freezes after exporting the PDF. I don't know if it has anything to do with the OpenAfterPublish property being set to True as I've always set it to False.
Edit2:
My mistake, It's simply because the UserForm is still open ...
The following code saves a selected area of my excel sheet. If I try to save a file that has the same file name as one that already exists, however, it will just save the file without showing the "Do you want to overwrite the file" dialog box.
Is there a way to change this code so that it will ask if I would like to overwrite the preexisting file?
Option Explicit
Sub CreatePDF()
Dim wSheet As Worksheet
Dim vFile As Variant
Dim sFile As String
Set wSheet = ActiveSheet
sFile = Replace(Replace(wSheet.Name, " ", ""), ".", "_") _
& "_" _
& Format(Now(), "yyyymmdd\_hhmm") _
& ".pdf"
sFile = ThisWorkbook.Path & "\" & sFile
vFile = Application.GetSaveAsFilename _
(InitialFileName:=sFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If vFile <> "False" Then
wSheet.Range("B2:J44").ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=vFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox "PDF file has been created."
End If
End Sub
One way to simulate the behavior, as suggested, is to check the selected SaveAsFilename:
Option Explicit
Sub CreatePDF()
Dim wSheet As Worksheet
Dim vFile As Variant
Dim sFile As String
Set wSheet = ActiveSheet
sFile = Replace(Replace(wSheet.Name, " ", ""), ".", "_") _
& "_" _
& Format(Now(), "yyyymmdd\_hhmm") _
& ".pdf"
sFile = ThisWorkbook.Path & "\" & sFile
vFile = Application.GetSaveAsFilename _
(InitialFileName:=sFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If Dir(vFile) > vbNullString Then _
If MsgBox("Overwrite File?", _
vbExclamation + vbYesNo, "Overwrite?") = vbNo Then Exit Sub
If vFile <> "False" Then
wSheet.Range("B2:J44").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=vFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox "PDF file has been created."
End If
End Sub
Another alternative:
Replace:
vFile = Application.GetSaveAsFilename _
(InitialFileName:=sFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If vFile <> "False" Then
By:
With Excel.Application.FileDialog(msoFileDialogSaveAs)
Dim i As Integer
For i = 1 To .Filters.Count
If InStr(.Filters(i).Extensions, "pdf") <> 0 Then Exit For
Next i
.FilterIndex = i
.InitialFileName = sFile
.Title = "Select Folder and FileName to save"
'------------------- Bloc A -------------------------
If CBool(.Show) Then
vFile = .SelectedItems.Item(.SelectedItems.Count)
End If
If vFile <> "" Then
'------------------- Bloc A -------------------------
'----------- Or replace "Bloc A" by------------------
'If Not CBool(.Show) Then Exit Sub
'vFile = .SelectedItems.Item(.SelectedItems.Count)
'And remove the "If vFile <> "False" Then" check
'----------------------------------------------------
End With
If you selected an existing file, the overwrite message will show
I have a button on one of the worksheets that lets user to continue with his task to save his/her template as a separate workbook in the folder.
Here is my code
Private Sub ContinueButton_Click()
Application.ScreenUpdating = 0
Sheets(cmbSheet.Value).Visible = True
Application.Goto Sheets(cmbSheet.Value).[a22], True
Application.ScreenUpdating = 1
Unload Me
End Sub
Now what I need is to check if that folder exist, in case if the folder does not exist my user should be able to create it.
My code to create this folder is here below, but how to connect this 2 functions together I simply have no idea, since I am fairly new to VBA
Sub CreateDirectory()
Dim sep As String
sep = Application.PathSeparator
'sets the workbook's path as the current directory
ChDir ThisWorkbook.Path
MsgBox "The current directory is:" & vbCrLf & CurDir
'makes new folder in current directory
MkDir CurDir & sep & Settings.Range("C45").Value
MsgBox "The archive directory named " & Settings.Range("C45").Value & " has been created. The path to your directory " & Settings.Range("C45").Value & " is below. " & vbCrLf & CurDir & sep & Settings.Range("C45").Value
End Sub
I am going to modularize your code a little bit:
First get the directory path here
Function getDirectoryPath()
getDirectoryPath = ThisWorkbook.Path & Application.PathSeparator & Settings.Range("C45").Value
End Function
You can create the directory using this function
Sub createDirectory(directoryPath)
MkDir directoryPath
End Sub
You can check if a directory exists or not using Dir function
Dir(directoryPath, vbDirectory) 'empty string means directoryPath doesn't exist
The final function on button click:
Private Sub ContinueButton_Click()
Application.ScreenUpdating = 0
Sheets(cmbSheet.Value).Visible = True
directoryPath = getDirectoryPath
'Creating the directory only if it doesn't exist
If Dir(directoryPath, vbDirectory) = "" Then
createDirectory directoryPath
End If
Application.Goto Sheets(cmbSheet.Value).[a22], True
Application.ScreenUpdating = 1
Unload Me
End Sub
I created a macro that will save as pdf certain tabs of my excel in a relative (variable)folder.
It will use the contract reference to create a subfolder, such subfolder label is exactly the contract reference. If subfolder already exists it just creates the files in it, else (subfolder does not exist) then it creates the folder and save the files in it.
Sub Gera_PDF_MG_Nao_Produtor_Sem_Ajuste()
Gera_PDF_MG_Nao_Produtor_Sem_Ajuste Macro
Dim MyFolder As String
Dim LaudoName As String
Dim NF1Name As String
MyFolder = ThisWorkbook.path & "\" & Sheets("Laudo").Range("C9")
LaudoName = Sheets("Laudo").Range("K27")
NF1Name = Sheets("MG sem crédito e sem ajuste").Range("Q3")
Sheets("Laudo").Select
Columns("D:P").Select
Selection.EntireColumn.Hidden = True
If Dir(MyFolder, vbDirectory) <> "" Then
Sheets("Laudo").ExportAsFixedFormat Type:=xlTypePDF, filename:=MyFolder & "\" & LaudoName & ".pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Sheets("MG sem crédito e sem ajuste").ExportAsFixedFormat Type:=xlTypePDF, filename:=MyFolder & "\" & NF1Name & ".pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Else
MkDir MyFolder
Sheets("Laudo").ExportAsFixedFormat Type:=xlTypePDF, filename:=MyFolder & "\" & LaudoName & ".pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Sheets("MG sem crédito e sem ajuste").ExportAsFixedFormat Type:=xlTypePDF, filename:=MyFolder & "\" & NF1Name & ".pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End If
Sheets("Laudo").Select
Columns("C:Q").Select
Selection.EntireColumn.Hidden = False
Range("A1").Select
'
End Sub
If Dir(Fldrpath, vbDirectory) = "" Then
MkDir Fldrpath
End If
Fldrpath refer to the Folderpath if Folder not found MkDir creates the folder