Saving multiple sheets to one location with one click - excel

The macro goes through each worksheet in the workbook, asks for a location to save each worksheet as a PDF, and then opens up an Outlook Email with a PDF attachment, one-by-one, ready to send to an end user.
I want to choose one location to save all PDF's without a prompt window coming up asking me where to save each worksheet.
Option Explicit
Sub WorksheetLoop()
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
Sheets(I).Select
Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object
CurrentMonth = ""
EmailSubject = "Bid Awarded to " & Range("D3") & " on " & Range("D2")
OpenPDFAfterCreating = False
AlwaysOverwritePDF = False
DisplayEmail = True
Email_To = Range("D4")
Email_CC = "Email#Email.com"
Email_BCC = ""
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
DestFolder = .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
End With
CurrentMonth = Mid(ActiveSheet.Range("H6").Value, InStr(1, ActiveSheet.Range("H6").Value, " ") + 1)
PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
& "_" & CurrentMonth & ".pdf"
If Len(Dir(PDFFile)) > 0 Then
If AlwaysOverwritePDF = False Then
OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If OverwritePDF = vbYes Then
Kill PDFFile
Else
MsgBox "OK then, 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
Else
On Error Resume Next
Kill PDFFile
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
Sheets(Array(ActiveWorkbook.Worksheets(I).Name)).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.Display
.To = Email_To
.CC = Email_CC
.BCC = Email_BCC
.Subject = EmailSubject & CurrentMonth
.Attachments.Add PDFFile
If DisplayEmail = False Then
.Send
MsgBox ActiveWorkbook.Worksheets(I).Name
End If
End With
Next I
End Sub
Right now, it opens an email for each worksheet but asks each time where to save the newly created PDF. I want it to save all worksheets to one designated location.

You need to move this bit...
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
DestFolder = .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
End With
Above your loop statement
You code should look like this...
Option Explicit
Sub WorksheetLoop()
Dim WS_Count As Integer
Dim I As Integer
Dim DestFolder as String ' Moved this above your Loop statement
WS_Count = ActiveWorkbook.Worksheets.Count
With Application.FileDialog(msoFileDialogFolderPicker) 'Move the folder selection code above your loop statement
If .Show = True Then
DestFolder = .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
End With
For I = 1 To WS_Count
Sheets(I).Select
Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object
CurrentMonth = ""
EmailSubject = "Bid Awarded to " & Range("D3") & " on " & Range("D2")
OpenPDFAfterCreating = False
AlwaysOverwritePDF = False
DisplayEmail = True
Email_To = Range("D4")
Email_CC = "anthony#narid.com"
Email_BCC = ""
CurrentMonth = Mid(ActiveSheet.Range("H6").Value, InStr(1, ActiveSheet.Range("H6").Value, " ") + 1)
PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
& "_" & CurrentMonth & ".pdf"
If Len(Dir(PDFFile)) > 0 Then
If AlwaysOverwritePDF = False Then
OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If OverwritePDF = vbYes Then
Kill PDFFile
Else
MsgBox "OK then, 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
Else
On Error Resume Next
Kill PDFFile
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
Sheets(Array(ActiveWorkbook.Worksheets(I).Name)).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.Display
.To = Email_To
.CC = Email_CC
.BCC = Email_BCC
.Subject = EmailSubject & CurrentMonth
.Attachments.Add PDFFile
If DisplayEmail = False Then
.Send
MsgBox ActiveWorkbook.Worksheets(I).Name
End If
End With
Next I
End Sub

Related

Excel for Mac- Converting tested windows Excel macro to Mac

I am a newbie to macros but I was able to find and modify a macro to works for what I needed. The macro is for a Form that once filled out the user will push the "Save and email" button and the following will happen:
save location window will open, the file will be converted and saved as .pdf (the file name is predetermined based on cells information)
the active sheet will be converted to .pdf it will be attached to an email.
I was very proud of my achievement until I tested it on my Mac and realized that it will not work. Now, I am faced with a challenge of converting the macro from Windows to Mac in order for the keep the functionality of the Form.
Below is the tested code on a Windows Excel:
Sub Button9_Click()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object, signature As String
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.Range("G3").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
.Subject = ActiveWorkbook.Sheets("FORM").Range("G3")
.To = "name"
.CC = " "
.body = "Hi ..," & vbLf & vbLf _
& "The Parts Request Form is attached in PDF format." & vbLf & vbLf _
& "Regards," & vbLf & vbLf _
& Application.UserName & vbLf & vbLf _
& "..." & vbLf _
& "..., ..." & vbLf _
& "..." & vbLf _
.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

export certain worksheets using a userform

I would like to make exports based on the boxes I checked
therefore with a lot of help I build the following code
Private Sub CommandButton1_Click()
Dim xSht As Worksheet, xFileDlg As FileDialog, xFolder As String, xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object, xEmailObj As Object, xUsedRng As Range, xArrShetts As Variant
Dim xPDFNameAddress As String, xStr As String, rngExp As Range, lastRng As Range
xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...
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
Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp) 'determine the last cell in A:A
Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7)) 'create the range to be exported as pdf
With xSht.PageSetup
.PaperSize = xlPaperA4
.PrintArea = rngExp.Address(0, 0)
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard, IgnorePrintAreas:=False 'export the range, not the sheet
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
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.Value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
Private Sub CommandButton2_Click()
Unload basicUserform
End Sub
the problem is when I run the code no attachments show up or can be found in the destination map I choose earlier.
I also put the file here so you can see for yourself.:
https://easyupload.io/ufnmvr
I appreciate your help and time!
Added a check for valid range of 27 or more rows otherwise lastRng.Offset(-26) will fail and because On Error Resume Next was not cancelled with On Error Goto 0 it won't raise an error.
Private Sub CommandButton1_Click()
Dim xSht As Worksheet, xFileDlg As FileDialog
Dim xFolder As String, xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object, xEmailObj As Object
Dim xUsedRng As Range, xArrShetts As Variant
Dim xPDFNameAddress As String, xStr As String
Dim rngExp As Range, lastRng As Range
xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...
If UBound(xArrShetts) < 0 Then
MsgBox "No sheets selected", vbExclamation
Exit Sub
End If
' check sheets exist
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
Exit Sub
End If
On Error GoTo 0
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 filename 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
'determine the last cell in A:A
Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp)
If lastRng.Row < 27 Then
MsgBox "Incorrect Start Row " & lastRng.Row, _
vbCritical, "ERROR on " & xSht.Name
Exit Sub
End If
'create the range to be exported as pdf
Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7))
With xSht.PageSetup
.PaperSize = xlPaperA4
.PrintArea = rngExp.Address(0, 0)
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
'export the range, not the sheet
rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, _
Quality:=xlQualityStandard, IgnorePrintAreas:=False
xArrShetts(I) = xStr
Else
' no file created
xArrShetts(I) = ""
End If
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.To = ""
.cc = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
If Len(xArrShetts(I)) > 0 Then
.Attachments.Add xArrShetts(I)
End If
Next
.Display ' or ' Send
End With
End Sub

How to Create PDF in Excel and Immediately Send as Email

I have an Excel sheet which is calculating the Performance Indicators of the Employees. I want to send their performance indicators via email. I am trying to use the following code.
Option Explicit
Sub create_and_email_pdf()
Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object
CurrentMonth = ""
EmailSubject = "Invoice Attached for "
OpenPDFAfterCreating = False
AlwaysOverwritePDF = False
DisplayEmail = True
Email_To = ""
Email_CC = ""
Email_BCC = ""
' ******************************************************
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
DestFolder = .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
End With
CurrentMonth = Mid(ActiveSheet.Range("G2").Value, InStr(1, ActiveSheet.Range("G2").Value, " ") + 1)
PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
& "_" & CurrentMonth & ".pdf"
If Len(Dir(PDFFile)) > 0 Then
If AlwaysOverwritePDF = False Then
OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If OverwritePDF = vbYes Then
Kill PDFFile
Else
MsgBox "OK then, 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
Else
On Error Resume Next
Kill PDFFile
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
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False
'Create an Outlook object and new mail message
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
'Display email and specify To, Subject, etc
With OutlookMail
.Display
.To = Email_To
.CC = Email_CC
.BCC = Email_BCC
.Subject = EmailSubject & CurrentMonth
.Attachments.Add PDFFile
If DisplayEmail = False Then
.Send
End If
End With
End Sub
When I try to run this code, it gives me the following error:
On debugging the code it shows me the following highlighted line.
Check the pdffile variable has valid path value, I can see you are generating the pdfile path.

Excel Vba Save file in pre-defined path based on static variable

I'm trying change the below to actually instead asking the path it should save to pre-definied path based on static variable + dynamic variable from cell.
If the folder dosen't exist it should be created.
Cansomeone guide me how to change this as I'm not VBA guru and it I can't find right solution at all.
Sub Pdf_To_EMail()
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
Dim xlSht As Excel.Worksheet
Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogSaveAs)
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"
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
'Zapisz jako plik PDF
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display False
.To = "Email#Email.com"
.CC = ""
.Subject = "”
.Body = ":"
.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
</code>
This should Work:
Currently it will check for a Folder on Your Desktop and Activesheet.Range("B2"), But you can change both of them in the String Formation xFolder
Sub Pdf_To_EMail()
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
Dim xlSht As Excel.Worksheet
Set xSht = ActiveSheet
''''New Code to detect if folder Exists
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
xFolder = Environ("USERPROFILE") & "\Desktop\" & xSht.Range("B2").Value '''' Change you path and cell Range
If objFSO.FolderExists(xFolder) Then
'do nothing
Else
objFSO.CreateFolder (xFolder) '
End If
xStr = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".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
'Zapisz jako plik PDF
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display False
.To = "Email#Email.com"
.CC = ""
.Subject = "”"
.Body = ":"
.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

VBA to send Excel Worksheet as PDF and Excel file

I found some coding to send my worksheet in an email as a pdf (I forgot what website it was on, so thank you if you created it on here!). I have been asked if I can include an excel version of the file in the email, along with the current pdf file (some people need it to copy and paste into other reports). Below is my current VBA. I cannot figure out how to also attach the current Worksheet as an excel file into the email as an attachment.
Thanks for any help!
Sub AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
' Not sure for what the Title is
Title = Range("A1")
' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = Format(Now(), "MM-dd-yyyy") & " File Name" & ".pdf"
' Export activesheet as PDF
With ActiveSheet
.PageSetup.PaperSize = xlPaperLegal
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = "Email Name " & Format(Now(), "MM-dd-yyyy")
.To = "xxx" ' <-- Put email of the recipient here
.CC = "" ' <-- Put email of 'copy to' recipient here
.Body = "All," & vbLf & vbLf _
& "xxx." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
' Try to send
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0
End With
' Delete PDF file
Kill PdfFile
' Release the memory of object variable
Set OutlApp = Nothing
End Sub
You could save a worksheet as pdf file and email it as an attachment using 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
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
For more information, please refer to this link:
How To Save A Worksheet As PDF File And Email It As An Attachment Through Outlook?
If you want to attach the current worksheet as an excel file into the email as an attachment, please refer to the below code:
Option Explicit
Sub EmailandSaveCellValue()
'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String, MailSub As String, MailTxt As String
'************************************************* ********
'Set email details; Comment out if not required
Const MailTo = "some1#someone.com"
Const MailCC = "some2#someone.com"
Const MailBCC = "some3#someone.com"
MailSub = "Please review " & Range("Subject")
MailTxt = "I have attached " & Range("Subject")
'************************************************* ********
'Turns off screen updating
Application.ScreenUpdating = False
'Makes a copy of the active sheet and save it to
'a temporary file
ActiveSheet.Copy
Set WB = ActiveWorkbook
FileName = Range("Subject") & " Text.xls"
On Error Resume Next
Kill "C:\" & FileName
On Error Goto 0
WB.SaveAs FileName:="C:\" & FileName
'Creates and shows the outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
.To = MailTo
.Cc = MailCC
.Bcc = MailBCC
.Subject = MailSub
.Body = MailTxt
.Attachments.Add WB.FullName
.Display
End With
'Deletes the temporary file
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close SaveChanges:=False
'Restores screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub
For more information, please refer to this link:
Send Excel sheet as email attachment using worksheet data.

Resources