I have a Macro that is largely doing what I need, but I would like to make the following changes to it.
- I would like the PDF to be saved in the same location as the Excel file it was created from. Currently it is asking me to select a location.
- I want to have it create a PDF of either the active worksheet or both the active and second worksheet based on the value in one specific cell. Currently it is only converting the active worksheet with no reference to any cell.
- If cell I16 equals either "New Install" or "Install" then the active sheet is converted along with worksheet 2 which is titled "Install Travel Lot" and emailed. The current macro names the PDF as the active worksheet which will always be worksheet 1 as that's where I have placed my Submit Button. I would like this to remain in place regardless of whether it's converting worksheet 2 or not.
- If cell I16 equals anything else, including remaining blank then only the active worksheet is converted and emailed. I16 currently contains a Data Validation List just in case that makes any difference
- The PDF is being named after the active worksheet. I would like the PDF to be named after the file name instead
Here is the current macro I have. It is fully functional with the exception of my wish list above. Thank you in advance for any help I may receive on this!
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 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 = ("[email protected]") .Subject = xSht.Name + "-" + xStr + ".pdf" .Attachments.Add xFolder If DisplayEmail = False Then '.Send End If End With Else