Macro to save as PDF with auto filename as cell value

[Joe Gray]

Hi I recently used the following Macro, provided by Gary's Student, to create a PDF from an active sheet, generate a unique Filename based on a cell ref and save it to a specific location.

This macro works well for me, however, I would like to add to it so that I can also attach it too and email and send to a specific email group (using Outlook). Maybe have it allow you to View so it can be sent manually, or the option to automatically send.

Below is the value I used to create the filename based on the date entry within I3 and I formatted it as shown.

Cell H1 "=I:\2017 - 2018\Operations Unit\Day Sheets\"&"DS_"&TEXT(I3,"yymmdd")&".PDF"

Sub Macro1()

s = Range("H1").Value

'

      ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

            s,  Quality:=xlQualityStandard, IncludeDocProperties _

            :=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

[#2]

Thanks Matt your a legend, never thought of that. I went with

=O4SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(C5,"/","_"),"\","_"),":","_"),"*","_"),"?","_"),"<","_"),">","_"),"*","_")&" "&SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(C9,"/","_"),"\","_"),":","_"),"*","_"),"?","_"),"<","_"),">","_"),"*","_")

[#3]

Hi, 

I have been using VBA for over a year, and have used it to refresh multiple pivot tables in a stepwise fashion.  I am using Excel 365 for Mac which seems to have introduced some challenges learning from this wonderful thread.

I would be grateful for any assistance.

Essentially, the PDF I would like to print is in a defined range on one of the worksheets in a workbook.  

The code below appears only to select the defined range, but does not print to a PDF driver.  

Many thanks ML

Sub PDF_Print_Summary()

'

' Print_test Macro

'

'

‘This is the name of the worksheet I want to print

    Sheets("Summary").Select

‘This is the range where the report sits in the worksheet

    Range("B1:U1").Select

    Range(Selection, Selection.End(xlDown)).Select

    Range("B1:U82").Select

‘In the set up of the PDF, I would like to be able define some parameters such as narrow margins, using A4 size paper

    Application.PrintCommunication = False

    With ActiveSheet.PageSetup

        .PrintTitleRows = ""

        .PrintTitleColumns = ""

    End With

    Application.PrintCommunication = True

    ActiveSheet.PageSetup.PrintArea = "$B$1:$U$82"

    Application.PrintCommunication = False

    With ActiveSheet.PageSetup

        .LeftHeader = ""

        .CenterHeader = ""

        .RightHeader = ""

        .LeftFooter = ""

        .CenterFooter = ""

        .RightFooter = ""

        .LeftMargin = Application.InchesToPoints(0.25)

        .RightMargin = Application.InchesToPoints(0.25)

        .TopMargin = Application.InchesToPoints(0.75)

        .BottomMargin = Application.InchesToPoints(0.75)

        .HeaderMargin = Application.InchesToPoints(0.3)

        .FooterMargin = Application.InchesToPoints(0.3)

        .PrintHeadings = False

        .PrintGridlines = False

        .PrintComments = xlPrintSheetEnd

        .CenterHorizontally = True

        .CenterVertically = True

        .Orientation = xlPortrait

        .Draft = False

        .PaperSize = xlPaperA4

        .FirstPageNumber = xlAutomatic

        .Order = xlDownThenOver

        .BlackAndWhite = False

        .Zoom = False

        .FitToPagesWide = 1

        .FitToPagesTall = 1

        .PrintErrors = xlPrintErrorsDisplayed

        .OddAndEvenPagesHeaderFooter = False

        .DifferentFirstPageHeaderFooter = False

        .ScaleWithDocHeaderFooter = True

        .AlignMarginsHeaderFooter = True

        .EvenPage.LeftHeader.Text = ""

        .EvenPage.CenterHeader.Text = ""

        .EvenPage.RightHeader.Text = ""

        .EvenPage.LeftFooter.Text = ""

        .EvenPage.CenterFooter.Text = ""

        .EvenPage.RightFooter.Text = ""

        .FirstPage.LeftHeader.Text = ""

        .FirstPage.CenterHeader.Text = ""

        .FirstPage.RightHeader.Text = ""

        .FirstPage.LeftFooter.Text = ""

        .FirstPage.CenterFooter.Text = ""

        .FirstPage.RightFooter.Text = ""

    End With

    Application.PrintCommunication = True

    Application.PrintCommunication = False

    With ActiveSheet.PageSetup

        .PrintTitleRows = ""

        .PrintTitleColumns = ""

    End With

    Application.PrintCommunication = True

    ActiveSheet.PageSetup.PrintArea = "$B$1:$U$82"

    Application.PrintCommunication = False

    With ActiveSheet.PageSetup

        .LeftHeader = ""

        .CenterHeader = ""

        .RightHeader = ""

        .LeftFooter = ""

        .CenterFooter = ""

        .RightFooter = ""

        .LeftMargin = Application.InchesToPoints(0.25)

        .RightMargin = Application.InchesToPoints(0.25)

        .TopMargin = Application.InchesToPoints(0.75)

        .BottomMargin = Application.InchesToPoints(0.75)

        .HeaderMargin = Application.InchesToPoints(0.3)

        .FooterMargin = Application.InchesToPoints(0.3)

        .PrintHeadings = False

        .PrintGridlines = False

        .PrintComments = xlPrintSheetEnd

        .CenterHorizontally = True

        .CenterVertically = True

        .Orientation = xlPortrait

        .Draft = False

        .PaperSize = xlPaperA4

        .FirstPageNumber = xlAutomatic

        .Order = xlDownThenOver

        .BlackAndWhite = False

        .Zoom = False

        .FitToPagesWide = 1

        .FitToPagesTall = 1

        .PrintErrors = xlPrintErrorsDisplayed

        .OddAndEvenPagesHeaderFooter = False

        .DifferentFirstPageHeaderFooter = False

        .ScaleWithDocHeaderFooter = True

        .AlignMarginsHeaderFooter = True

        .EvenPage.LeftHeader.Text = ""

        .EvenPage.CenterHeader.Text = ""

        .EvenPage.RightHeader.Text = ""

        .EvenPage.LeftFooter.Text = ""

        .EvenPage.CenterFooter.Text = ""

        .EvenPage.RightFooter.Text = ""

        .FirstPage.LeftHeader.Text = ""

        .FirstPage.CenterHeader.Text = ""

        .FirstPage.RightHeader.Text = ""

        .FirstPage.LeftFooter.Text = ""

        .FirstPage.CenterFooter.Text = ""

        .FirstPage.RightFooter.Text = ""

    End With

    Application.PrintCommunication = True

    ActiveSheet.PageSetup.PrintArea = "$B$1:$U$82"

    Application.PrintCommunication = False

    With ActiveSheet.PageSetup

        .PrintTitleRows = ""

        .PrintTitleColumns = ""

    End With

    Application.PrintCommunication = True

    ActiveSheet.PageSetup.PrintArea = "$B$1:$U$82"

    Application.PrintCommunication = False

    With ActiveSheet.PageSetup

        .LeftHeader = ""

        .CenterHeader = ""

        .RightHeader = ""

        .LeftFooter = ""

        .CenterFooter = ""

        .RightFooter = ""

        .LeftMargin = Application.InchesToPoints(0.236220472440945)

        .RightMargin = Application.InchesToPoints(0.236220472440945)

        .TopMargin = Application.InchesToPoints(0.748031496062992)

        .BottomMargin = Application.InchesToPoints(0.748031496062992)

        .HeaderMargin = Application.InchesToPoints(0.31496062992126)

        .FooterMargin = Application.InchesToPoints(0.31496062992126)

        .PrintHeadings = False

        .PrintGridlines = False

        .PrintComments = xlPrintSheetEnd

        .CenterHorizontally = True

        .CenterVertically = True

        .Orientation = xlPortrait

        .Draft = False

        .PaperSize = xlPaperA4

        .FirstPageNumber = xlAutomatic

        .Order = xlDownThenOver

        .BlackAndWhite = False

        .Zoom = False

        .FitToPagesWide = 1

        .FitToPagesTall = 1

        .PrintErrors = xlPrintErrorsDisplayed

        .OddAndEvenPagesHeaderFooter = False

        .DifferentFirstPageHeaderFooter = False

        .ScaleWithDocHeaderFooter = True

        .AlignMarginsHeaderFooter = True

        .EvenPage.LeftHeader.Text = ""

        .EvenPage.CenterHeader.Text = ""

        .EvenPage.RightHeader.Text = ""

        .EvenPage.LeftFooter.Text = ""

        .EvenPage.CenterFooter.Text = ""

        .EvenPage.RightFooter.Text = ""

        .FirstPage.LeftHeader.Text = ""

        .FirstPage.CenterHeader.Text = ""

        .FirstPage.RightHeader.Text = ""

        .FirstPage.LeftFooter.Text = ""

        .FirstPage.CenterFooter.Text = ""

        .FirstPage.RightFooter.Text = ""

    End With

    Application.PrintCommunication = True

End Sub

[#4]

HI Mark,

I would guess you have two options.

1. export the range without formatting (as the formatting happens to the worksheet not the pdf) see this link for an example vba-script-that-saves-excel-range-as-pdf

or 

2. copy the data (range) to a prepared,formatted sheet or, new sheet and script the formatting. Then export the whole sheet using the previous examples in this thread.

[#5]

Worked great..saves me at least 2hrs a week!

[#6]

@Andrew Jones 

code as you share not works in window 7/10 64 bit .  my cvode be below

Declare Function RegOpenKeyA Lib "advapi32.dll" ( _
ByVal Key As Long, _
ByVal SubKey As String, _
NewKey As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" ( _
ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" ( _
ByVal hKey As Long) As Long

Sub PrintPDF()
Dim sPath As String
Dim strDefaultPrinter As String
Dim strOutFile As String
Dim lngRegResult As Long
Dim lngResult As Long
Dim dhcHKeyCurrentUser As Long
Dim PDFPath As String
Const dhcRegSz As Long = 1

dhcHKeyCurrentUser = &H80000001
strDefaultPrinter = Application.ActivePrinter

sPath = "D:\JOBCARD201920"
PDFPath = sPath

strOutFile = PDFPath & "\" & Range("G3").VALUE & ".pdf"


lngRegResult = RegOpenKeyA(dhcHKeyCurrentUser, "Software\Adobe\Acrobat Distiller\PrinterJobControl", _
lngResult)
lngRegResult = RegSetValueEx(lngResult, Application.Path & "\Excel.exe", 0&, dhcRegSz, ByVal strOutFile, Len(strOutFile))
lngRegResult = RegCloseKey(lngResult)

ThisWorkbook.ActiveSheet.PrintOut copies:=1, ActivePrinter:="Adobe PDF"
Application.ActivePrinter = strDefaultPrinter

end sub

[#7]

@Matt Mickle 

old post but wondering if you could help as this is very close to what I need, however I am a VBA novice and I can't make the small changes work in my favour!! 

I need a code to do the following:

> Save active worksheet only as a PDF, as the name from cell "M7"

> Save in to specific file path however with a variable final location based on specific name, taken from cell "W3"

> Open Outlook and attached this PDF file in a new email

> Add Subject of "PO & PDF File Name (or cell "M7")

> Add body of "Hi (line break x2) *insert text* (line break x2) *Date & cell "M10"* (line break x1) *Booking Slot & Cell "W6"* (line break x2) *insert text* (line break x2) *Regards*

Would be really grateful if you are able to help.

Thanks

James

[#8]

@Matt Mickle 

Hi Matt, found this code and it is very close to what I am after, however I am a complete VBA novice and the small changes I need to make I can't seem to make work. Are you able to advise? Would be really appreciated.

So I need to do the following if possible:

> Save the active worksheet as a PDF, using Cell "M7" for the name and saved in to a specific file path (which I will put in to the code), however with the final folder name to save in to being specific to Cell "W3" which will change via a drop down option

> Open Outlook new email and attached the PDF

> In "to" use email addresses from Cell "X3, Y3 and Z3" (sometimes 1 or 2 of these may be blank, will this cause an error?)

> In subject add "PO & Cell M7 (or PDF File name)

> In body add "Text" (line break x2) "text" (line break x2) "text & Cell M10" (line break x1) "text & Cell W6" (line break x2) "text" (line break x2) "text" end

Thanks

James