Note: The other languages of the website are Google-translated. Back to English
English English

How to save a worksheet as PDF file and email it as an attachment through Outlook?

In some cases, you may need to send a worksheet as a PDF file through Outlook. Usually, you have to manually save the worksheet as a PDF file, then create a new email with this PDF file as attachment in your Outlook and finally send it. It is time-consuming to achieve it manually step by step. In this article, we will show you how to quickly save a worksheet as a PDF file and send it automatically as an attachment through Outlook in Excel.

Save a worksheet as PDF file and email it as an attachment with VBA code


Save a worksheet as PDF file and email it as an attachment with VBA code


You can run the below VBA code to automatically save active worksheet as a PDF file, and then email it as an attachment through Outlook. Please do as follows.

1. Open the worksheet you will save as PDF and send, then press the Alt + F11 keys simultaneously to open the Microsoft Visual Basic for Applications window.

2. In the Microsoft Visual Basic for Applications window, click Insert > Module. Then copy and paste the below VBA code into the Code window. See screenshot:

VBA code: Save a worksheet as PDF file and email it as an attachment

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file 
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
    
    'Create Outlook email 
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = ""
        .CC = ""
        .Subject = xSht.Name + ".pdf"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub

3. Press the F5 key to run the code. In the Browse dialog box, please select a folder to save this PDF file, and then click the OK button.

Notes:

1. Now the active worksheet is saved as PDF file. And the PDF file is named with the worksheet name.
2. If the active worksheet is blank, you will get a dialog box as below screenshot shown after clicking the OK button.

4. Now a new Outlook email is created and you can see the PDF file is listed as an attachment in the Attached filed. See screenshot:

5. Please compose this email and then send it.
6. This code is only available when you use Outlook as your mail program.

Easily save a worksheet or multiple worksheets as separate PDF files at once:

The Split Workbook utility of Kutools for Excel can help you easily save a worksheet or multiple worksheets as separate PDF files at once as the below demo shown. Download and try it now! ( 30-day free trail)


Related articles:


The Best Office Productivity Tools

Kutools for Excel Solves Most of Your Problems, and Increases Your Productivity by 80%

  • Reuse: Quickly insert complex formulas, charts and anything that you have used before; Encrypt Cells with password; Create Mailing List and send emails...
  • Super Formula Bar (easily edit multiple lines of text and formula); Reading Layout (easily read and edit large numbers of cells); Paste to Filtered Range...
  • Merge Cells/Rows/Columns without losing Data; Split Cells Content; Combine Duplicate Rows/Columns... Prevent Duplicate Cells; Compare Ranges...
  • Select Duplicate or Unique Rows; Select Blank Rows (all cells are empty); Super Find and Fuzzy Find in Many Workbooks; Random Select...
  • Exact Copy Multiple Cells without changing formula reference; Auto Create References to Multiple Sheets; Insert Bullets, Check Boxes and more...
  • Extract Text, Add Text, Remove by Position, Remove Space; Create and Print Paging Subtotals; Convert Between Cells Content and Comments...
  • Super Filter (save and apply filter schemes to other sheets); Advanced Sort by month/week/day, frequency and more; Special Filter by bold, italic...
  • Combine Workbooks and WorkSheets; Merge Tables based on key columns; Split Data into Multiple Sheets; Batch Convert xls, xlsx and PDF...
  • More than 300 powerful features. Supports Office/Excel 2007-2019 and 365. Supports all languages. Easy deploying in your enterprise or organization. Full features 30-day free trial. 60-day money back guarantee.
kte tab 201905

Office Tab Brings Tabbed interface to Office, and Make Your Work Much Easier

  • Enable tabbed editing and reading in Word, Excel, PowerPoint, Publisher, Access, Visio and Project.
  • Open and create multiple documents in new tabs of the same window, rather than in new windows.
  • Increases your productivity by 50%, and reduces hundreds of mouse clicks for you every day!
officetab bottom
Comments (61)
Rated 5 out of 5 · 1 ratings
This comment was minimized by the moderator on the site
This is working great for me but is there a way to select a folder location automatically rather than select manually? I am hoping to do this for 40 sheets at once.
This comment was minimized by the moderator on the site
Also hoping to see an answer for this issue! Thanks for the help!
This comment was minimized by the moderator on the site
I have tried pasting this into a new module and i get Compile error: Sub or Function not defined. Please help.
This comment was minimized by the moderator on the site
Dear Darren,
Which Office version do you use?
This comment was minimized by the moderator on the site
Office 360
This comment was minimized by the moderator on the site
Same issue
This comment was minimized by the moderator on the site
How would I edit the VBA script above so that it adds a date and time stamp to the file name that way it doesn't keep overwriting what is already saved?
This comment was minimized by the moderator on the site
Dear Michael,
Please run the below VBA code to solve the problem.

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xStr As String

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xStr = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = xSht.Name + "-" + xStr + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
This comment was minimized by the moderator on the site
Hi Crystal,

It's really great and working perfectly for me. Need more help to add:

1. in "To" I want to give link to particular cell of Active sheet like wise in CC and in BCC i would like to add active sheet link
2. in e-mail body i need to specify some standard text.

I will be great full to you for your help.

Thanks
Parag
This comment was minimized by the moderator on the site
Hi Parag Somani,
The below VBA code can help you. Please change the .To, .CC, .BCC and .Body fields based on your needs.

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xStr As String

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xStr = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = Range("A8")
.CC = Range("A9")
.BCC = Range("A10")
.Subject = xSht.Name + "-" + xStr + ".pdf"
.Body = "Dear " _
& vbNewLine & vbNewLine & _
"This is a test email " & _
"sending in Excel"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
This comment was minimized by the moderator on the site
I have been trying to use the Range for "To", "CC", it just doesn't pick up the values from the designated cell. Can you please help on this?
Thanks,
Mehul
This comment was minimized by the moderator on the site
Hi Crystal,

It's really great and working perfectly for me. Need more help to add:

1. in "To" I want to give link to particular cell of Active sheet like wise in CC and in BCC i would like to add active sheet link
2. in e-mail body i need to specify some standard text.

I will be great full to you for your help.

Thanks
Parag
This comment was minimized by the moderator on the site
Hi Crystal,

It's really great and working perfectly for me. Need more help to add:

1. in "To" I want to give link to particular cell of Active sheet like wise in CC and in BCC i would like to add active sheet link
2. in e-mail body i need to specify some standard text.

I will be great full to you for your help.

Thanks
Parag
This comment was minimized by the moderator on the site
How can I add for example sheet 2 from the workbook as an pdf?
This comment was minimized by the moderator on the site
Hi Armin,
You need to open the Sheet 2 in your workbook firstly and then run the VBA code with above steps to get it down.
This comment was minimized by the moderator on the site
How would I edit the VBA script above so that the file name is saved as a specific cell selected within the current sheet, for example cell A1?
This comment was minimized by the moderator on the site
Hi Tom.
Sorry can’t help with this.
Welcome to post any question in our forum: https://www.extendoffice.com/forum.html
You will get more Excel support from out Excel professional or other Excel fans.
This comment was minimized by the moderator on the site
Hi, how can i save & send the pdf wit the workbook name with the current VBA code? what do i use instead of xSht.Name
This comment was minimized by the moderator on the site
Hi James,
Do you want to send the active worksheet as pdf and name it as the workbook name?
This comment was minimized by the moderator on the site
Thanks it works.
This comment was minimized by the moderator on the site
How can I make it delete the saved pdf after it emails it?
This comment was minimized by the moderator on the site
Hi Jason,
Sorry can't help you with that yet. You need to manually delete it after emailing it.
This comment was minimized by the moderator on the site
Hello,

Is it possible to find the name for pdf from a cell? Ex. Cell H4


And in Cell H4 i want it to collect from three different cells. Is this possible?
This comment was minimized by the moderator on the site
This is possible. Make separate variables to hold the value from the cells and then use those variables when setting xFolder.
I used the value from a cell in my sheet plus today's date. You could easily do multiple cell values though.

This is what I added:
Dim xMemberName As String
Dim xFileDate As String

xMemberName = Range("H3").Value
xFileDate = Format(Now, "mm-dd")

xFolder = xFolder + "\" xMemberName + xFileDate + ".pdf"
This comment was minimized by the moderator on the site
I am getting an error when i try this, where in the code should i place this ?
This comment was minimized by the moderator on the site
Hi Crystal,



It's really great and working perfectly for me. Need more help to add:

1. in "Body" I want to give link to particular cell of Active sheet. Further Would like to Bold the text.

Thanks

Regards

Kishore Kumar
This comment was minimized by the moderator on the site
Hi,

Do you mean to add the cell value automatically to the mailbody and bold it? Supposing you add the value of C4 to the mail body. Please apply the below code.

Sub Saveaspdfandsend()

Dim xSht As Worksheet

Dim xFileDlg As FileDialog

Dim xFolder As String

Dim xYesorNo As Integer

Dim xOutlookObj As Object

Dim xEmailObj As Object

Dim xUsedRng As Range



Set xSht = ActiveSheet

Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)



If xFileDlg.Show = True Then

xFolder = xFileDlg.SelectedItems(1)

Else

MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"

Exit Sub

End If

xFolder = xFolder + "\" + xSht.Name + ".pdf"



'Check if file already exist

If Len(Dir(xFolder)) > 0 Then

xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _

vbYesNo + vbQuestion, "File Exists")

On Error Resume Next

If xYesorNo = vbYes Then

Kill xFolder

Else

MsgBox "if you don't overwrite the existing PDF, I can't continue." _

& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"

Exit Sub

End If

If Err.Number <> 0 Then

MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _

& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"

Exit Sub

End If

End If



Set xUsedRng = xSht.UsedRange

If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then

'Save as PDF file

xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard



'Create Outlook email

Set xOutlookObj = CreateObject("Outlook.Application")

Set xEmailObj = xOutlookObj.CreateItem(0)

With xEmailObj

.Display

.To = ""

.CC = ""

.Subject = xSht.Name + ".pdf"

.Attachments.Add xFolder

.HTMLBody = "
" & Range("C4") & .HTMLBody

If DisplayEmail = False Then

'.Send

End If

End With

Else

MsgBox "The active worksheet cannot be blank"

Exit Sub

End If

End Sub
This comment was minimized by the moderator on the site
If I were wanting it to autosave in a specific folder each and every time (eliminating the need for the user to choose the folder), how would i do that?
Ex. C: Invoices/NorthAmerica/Clients
Help is greatly appreciated.
This comment was minimized by the moderator on the site
Hi Geoff,
Do you mean save the worksheet as an pdf file and save into a specific folder without sending?
This comment was minimized by the moderator on the site
I think Geoff means being able to specific a specific folder in the code that the pdf is saved to each time rather than having to select the location manually. The pdf is then emailed from that specific folder.
This comment was minimized by the moderator on the site
Thank you Jeremy.
This comment was minimized by the moderator on the site
Hi Geoff,If you want to automatically save the pdf file to a specific folder rather than selecting the location manually, please try the below code. Don't forget to change the folder path in the code.
<div data-tag="code">Sub SaveAsPDFandSend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xPath As String
Set xSht = ActiveSheet
xPath = "C:\Users\Win10x64Test\Desktop\worksheet to pdf" 'here "workshet to pdf" is the destination folder to save the pdf files
xFolder = xPath + "\" + xSht.Name + ".pdf"
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
This comment was minimized by the moderator on the site
This code works great except i want to have the worksheet saved as sheet name + date (ie. Sheet1 Oct 1 2020); on the user's desktop (this will be used by multiple people and their paths may vary slightly). If possible, i want to embed a .jpg into the body as well.. the JPG is located both inside the worksheet (outside of print area) and the image is stored on a shared server.. though the path to the server varies by user (for most it is a "T" drive for some a "U" drive)
can this be done? please and thank you a million times.
This comment was minimized by the moderator on the site

Hi , it's working great thank you for sharing, Just need one help.
If I want to save a PDF file with customized name (option to type file name in SaveAs dialog box), as user's use this option in form template where forms saved as PDF with unique name .
This comment was minimized by the moderator on the site
Hi,Please try the below VBA code. After running the code, select a folder to save the PDF file, then a dialog box will pop up for you to enter the filename.<div data-tag="code">Sub Saveaspdfandsend()
'Updated by Extendoffice 20210209
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xStrName As String
Dim xV As Variant

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xStrName = ""
xV = Application.InputBox("Please enter the filename:", "Kutools for Excel", , , , , , 2)
If xV = False Then
Exit Sub
End If
xStrName = xV
If xStrName = "" Then
MsgBox ("No filename entered, exiting process!")
Exit Sub
End If

xFolder = xFolder + "\" + xStrName + ".pdf"
'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
This comment was minimized by the moderator on the site
Hi,
If I have two sheets in file, and I would like to run this macro on one sheet(by pressing button) but send another, how can I get it?
This comment was minimized by the moderator on the site
Hello, i would like to save this in a certain file location, with the name based on the vallue in cell C30.I have tried a few options, but keep getting faults.
This comment was minimized by the moderator on the site
Hi hein,The below code maybe can help. After running the code, select a certain folder to save the PDF file, then a dialog box will pop up for you to enter the filename.<div data-tag="code">Sub Saveaspdfandsend()
'Updated by Extendoffice 20210209
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xStrName As String
Dim xV As Variant

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xStrName = ""
xV = Application.InputBox("Please enter the filename:", "Kutools for Excel", , , , , , 2)
If xV = False Then
Exit Sub
End If
xStrName = xV
If xStrName = "" Then
MsgBox ("No filename entered, exiting process!")
Exit Sub
End If

xFolder = xFolder + "\" + xStrName + ".pdf"
'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
This comment was minimized by the moderator on the site
Thanks for that, thats great, but i want the sheet to be named as per cell A1 on sheet 1. the place to save as per A1 on sheet 2 for example C:\Users\peete\Dropbox\Screenshots, and email send to email address on A3 sheet 2 what I have worked out already.
This comment was minimized by the moderator on the site
Thanks for that, thats great, but i want the sheet to be named as per cell A1 on sheet 1. the place to save as per A1 on sheet 2 for example C:\Users\peete\Dropbox\Screenshots, but can change when using the file, and email send to email address on A3 sheet 2 what I have worked out already.
This comment was minimized by the moderator on the site
Hi crystal , excelent code thanks for sharing.Is there a way to select multiples sheets (from the same workbook) to save each one as an independent PDF and then send them all attached in one email?
This comment was minimized by the moderator on the site
Hi,The below VBA code can do you a favor, please have a try.In the the twelfth line of the code, please replace the sheet names with the actual sheet names in your case.
<div data-tag="code">Sub Saveaspdfandsend1()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.

For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next


Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))

xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
Else

End If
xArrShetts(I) = xStr
Next

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If DisplayEmail = False Then
'.Send
End If
End With
End Sub
This comment was minimized by the moderator on the site
Hi,The one change i am struggling with is to create a separate email for each pdf document created.
This comment was minimized by the moderator on the site
Hi,To create a separate email for each pdf document, you can manually run the VBA provided in the post in different worksheets to get it done.
This comment was minimized by the moderator on the site
I have more than 100 worksheets in the workbook, which wil then entail that i have to run the VBA more than 100 times, which is time consuming.  
I have managed to split my workbook into the multiple sheet and then i am able to convert each worksheet to an individual PDF document.
The solution i am looking for, is to email each PDF document separately while the above process is running.
Herewith the VBA I am currently running:
Sub Saveaspdfandsend1()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
xArrShetts = Array("02302257", "02400438", "02401829", "02403995", "02408001", "02409208", _
"02409980", "02411881", "02424178", "02430454", "02444046", "02448950", "02450600", _
"02459861", "02461750", "02467535", "02480484", "02484749", "02502041", "02504807", _
"02511843", "02515193", "02523098", "02523244", "02524036", "02524548", "02525516", "02525703", "02525898", "02528908", "02528950", _
"02530381", "02531018", "02531252", "02531277", "02532571", "02533053", "02533474", _
"02534176", "02534592", "02534626", "02535343", "02536386", "02536921", "02537544", _
"02537607", "02538015", "02538755", "02538836", "02538910", "02539685", "02540063", "02540139", "02540158", "02541607", "02542344", _
"02543763", "02543985", "02544116", "02544748", "02544762", "02545026", "02545048", _
"02545080", "02545447", "02545730", "02545814", "02546477", "02547458", "02547673", _
"02547833", "02547912", "02547950", "02547991", "02548848", "02549103", "02549116", "02549125", "02549132", "02549140", "02549182", _
"02549462", "02549499", "02549565", "02549687", "02550049", "02550437", "02550812", _
"02550982", "02551004", "02551005", "02551045", "02552099", "02552222", "02552561", _
"02552684", "02552815", "02552892", "02553031", "02553186", "02553628", "02553721", "02555186", "02556934", "02557137", "02557393", _
"02559121", "02559392", "02559419", "02559512", "02559802", "02559868", "02560052", _
"02560612", "02560684", "02560920", "02561018", "02561061", "02561092", "02561227", _
"02561349", "02561592", "02561630", "02561673", "02561880", "02562359", "02562920", "02562934", "02563013", "02563119", "02563133", _
"02563445", "02563737", "02563828", "02563852", "02563861", "02563971", "02564042", _
"02564315", "02564366", "02564832", "02564909", "02565059", "02565205") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.

For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next


Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))

xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
Else

End If
xArrShetts(I) = xStr
Next

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = "Ctracklegal@ctrack.com"
.CC = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
On Error Resume Next
.Attachments.Add xArrShetts(I)
Next
If DisplayEmail = False Then
.Send
Exit Sub
End If
End With


End Sub
This comment was minimized by the moderator on the site
Hi @crystal
This is fab - the o key thing I am struggling with is the file name - I’d like the file name to pull from a cell in the worksheet rather than use the tab name. I’ve already edited the code to save automatically to a specified folder but am struggling with the file name.
Any help you can offer please?
This comment was minimized by the moderator on the site
Hi Tori,If you want to name the PDF file with a specific cell value, please try the following code.After running the code and selecting a folder to save the file, another dialog box pops up, please select the cell that you will use the value as the name of the PDF file, and then click OK to finish.
<div data-tag="code">Sub Saveaspdfandsend2()
'Updated by Extendoffice 20210521
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng, xRgInser As Range
Dim xB As Boolean
Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xB = True
On Error Resume Next
While xB
Set xRgInser = Nothing
Set xRgInser = Application.InputBox("Select a cell that you will use the value to name the PDF file:", "Kutools for Excel", , , , , , 8)
If xRgInser Is Nothing Then
MsgBox " No cell seleced, exit the operation! ", vbInformation, "Kutools for Excel"
Exit Sub
End If
If xRgInser.Text = "" Then
MsgBox " The selected cell is blank, please reselect! ", vbInformation, "Kutools for Excel"
Else
xB = False
End If
Wend

xFolder = xFolder + "\" + xRgInser.Text + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
This comment was minimized by the moderator on the site
Hi,I needed something similar so here is what I got.It takes the current date and creates a new folder with the date name in a specific location.It places the pdf inside that new location, then attaches the pdf into a new email. Works as a treat. I am just a beginner so please excuse me if it looks like a mess. :D
Sub PDFTOEMAIL()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xPath As String
Dim xOutMsg As String
Dim sFolderName As String, sFolder As String
Dim sFolderPath As String

Set xSht = ActiveSheet
xFileDate = Format(Now, "dd-mm-yyyy")
sFolder = "C:" 'here is where you have a main folder
sFolderName = "Week ending " + Format(Now, "dd-mm-yyyy") 'folder to be created in main folder with name Week ending and current date
sFolderPath = "C:" & sFolderName 'main folder again to create the new path including the new folder
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FolderExists(sFolderPath) Then
MsgBox "Folder already exists !" & vbCrLf & vbCrLf & sFolderPath, vbInformation, "INFO"
Else
MkDir sFolderPath
MsgBox "New folder has been created !" & vbCrLf & vbCrLf & sFolderPath, vbInformation, "INFO"
End If
xPath = sFolderPath
xFolder = xPath + "\" + xSht.Name + "_" + xFileDate + ".pdf"
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
xOutMsg = "<b>Please find attached</b><br/><br/><br/><br/><br/><br/><br/><br/><br/><br/><br/><br/><span style=""color:#00FF00;background:#000000"">This email and attachment has been generated automatically</span>"
'adds a note that the email was generated automatically

With xEmailObj
.Display
.To = "" 'add your own emails
.CC = ""
.Subject = xSht.Name + " PDF for week ending " + xFileDate + " - Location " ' subject includes sheet name, pdf, date and location, this can be edited as needed
.Attachments.Add xFolder
.HTMLBody = xOutMsg & .HTMLBody
If DisplayEmail = False Then
'.Send <--- Here if you delete the apostrophe the email will be sent automatically, so please be careful
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
This comment was minimized by the moderator on the site
How do I edit this code to only save cells ("a1:r99") to save as the PDF. I have extra stuff on the sides I don't want in my PDF document.
Sub Saveaspdfandsend()
'Updated by Extendoffice 20210209
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xStrName As String
Dim xV As Variant

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xStrName = ""
xV = Application.InputBox("Please enter the filename:", "Kutools for Excel", , , , , , 2)
If xV = False Then
Exit Sub
End If
xStrName = xV
If xStrName = "" Then
MsgBox ("No filename entered, exiting process!")
Exit Sub
End If

xFolder = xFolder + "\" + xStrName + ".pdf"
'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
This comment was minimized by the moderator on the site
Hello, I just tried this code on one of my worksheets and I have print areas set so the extra stuff at the bottom did not appear in the pdf. Try it!
This comment was minimized by the moderator on the site
Hi
Many thanks for the Code but is it possible to save the the PDF automatically to the same location as the active Excel file and with the same file name as the active Excel file?
Many thanks.
Rod
There are no comments posted here yet
Load More
Leave your comments
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations