Save as PDF with special function

[LaLorenzen]

Dear Excel friends
I hope there is a smart person out there who can help me with a small Macro (Excel 2010) – I have been in contact with a lot of friends in Denmark that normally work with excel, but nobody seems able to help me. Why I hope there is a "geek" in this forum that can help me..

The problem
I need a Marco that can save a specific area of a spreadsheet as a PDF file
Filename: Cell A1
Path: Cell A2 (E.g C:\Users\Lasse Lorenzen\)
Area: Cell B1 (A4:H158)
Paper Oriental Landscape
Size Scale to fit one page

If possible
If Cell B2 is TRUE open the pdf file after it have been saved – False just save the PDF without opening the pdf.
Bonus Info: If the file already excised overwrite the filename

Kind Regards
- Lasse Lorenzen

 

[RatExcel]

Cell A1: Name of the workbook which you want to print as PDF - has to end with valid Excel extension! e.g. *.xlsx, *.xls, *.csv etc.

Cell A2: Directory where the above file is stored - only directory, no file name!

Cell B1: Range or Sheet Name & Range joined by "!".

Cell B2: True or False to open the PDF or not after printing.

If PDF file already exists it will be overwritten.


Sample workbook here:

https://app.box.com/s/dd4ut4q851zqe2p3gai9fzy4hei5d2yv

Code:

Sub SaveAsPDF()

    Set mWb = Workbooks(ThisWorkbook.Name)
    Set mWs = mWb.ActiveSheet

    If Right(Trim(mWs.Cells(2, 1)), 1) <> Application.PathSeparator Then
        fDir = Trim(mWs.Cells(2, 1)) & Application.PathSeparator
    Else
        fDir = Trim(mWs.Cells(2, 1))
    End If
    
    If Left(Right(Trim(mWs.Cells(1, 1)), Len(Trim(mWs.Cells(1, 1))) - InStrRev(Trim(mWs.Cells(1, 1)), ".")), 2) <> "xl" And _
        Left(Right(Trim(mWs.Cells(1, 1)), Len(Trim(mWs.Cells(1, 1))) - InStrRev(Trim(mWs.Cells(1, 1)), ".")), 2) <> "cs" Then
        MsgBox "There is no extenstion provided in the file name or the file is not an Excel file!", vbCritical, "Error"
        Exit Sub
    Else
        fName = Trim(mWs.Cells(1, 1))
    End If
    
    pdfName = fDir & Left(fName, InStrRev(fName, ".")) & "pdf"

    Application.DisplayAlerts = False
    Set wb = Workbooks.Open(fDir & fName)
    Application.DisplayAlerts = True
    
    mRng = WorksheetFunction.Substitute(Trim(mWs.Cells(1, 2)), "'", vbNullString)
    
    If InStr(1, mRng, "!") Then
        Set ws = wb.Sheets(Left(mRng, InStr(1, mRng, "!") - 1))
        mRng = Right(mRng, Len(mRng) - InStr(1, mRng, "!"))
    Else
        Set ws = wb.Sheets(1)
    End If
    
    If Trim(mWs.Cells(2, 2)) = "TRUE" Or mWs.Cells(2, 2) = True Then
        mOAP = True
    Else
        mOAP = False
    End If
    
    With ws.PageSetup
        .Orientation = xlLandscape
        .PrintArea = mRng
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    
    Application.DisplayAlerts = False
    ws.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=pdfName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=mOAP
    Application.DisplayAlerts = True
        
    wb.Close False
    
    MsgBox "Done!", vbInformation, "Info"

End Sub

 

[LaLorenzen]

Re: Save as PDF with special function_

Dear RatExcel
First of all, thanks for the fast replay. I think the macro is working. But for some reason that I not are familiar with, will the PDF not be generated. I can see that Adobe reader start up but after 0.1 second closed again (Doesn't matter if the settings in B2 is True or false) without creating a PDF.

I have other “PDF” macro´s in the spreadsheet that works without any problem. But I don´t know if it is written in another “macro” langue’s (See below).

By the way
Is it possible, that the XLSM file have one name and the PDF a different name and folders?
XLSM = Customer name, Product number, date and responsible
PDF = Product number, version


- Lasse
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

'Create PDF of active sheet only
strPath = Environ$("temp") & "\" 'Or any other path, but include trailing "\"

With ActiveSheet
Set rngPP = .Range("O2")
Set rngen = .Range("O3")
Set rngTo = .Range("O4")
Set rngSubject = .Range("O5")
Set rngBody = .Range("O6")

End With

strFName = ActiveWorkbook.Name
strFName = Left(strFName, InStrRev(strFName, ".") - 1) & "_" & ActiveSheet.Name & ".pdf"
ActiveSheet.PageSetup.PrintArea = rngPP.Value
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
strPath & strFName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

 

[RatExcel]

Re: Save as PDF with special function_

Have you provided all needed details as file path, file name etc in cell A1 to B2?

 

[LaLorenzen]

Re: Save as PDF with special function - step3

Hi RarExcel
I think I have all the necessary setting (See the picture below) but for some reason will the PDF not be created.
When I push the bottom [Save As PDF] can I see that for a split second that the name [cell A1] change from LLz1.xlsm to LLz2.xlsm

- Lasse

url: https://www.dropbox.com/s/zmx5qxrdjw7pgjo/26-01-2015 12-01-40.png?dl=0

 

[RatExcel]

Re: Save as PDF with special function - step3

Do you have a sheet called "SaveAsPDF" in your "LLz1.xlsm" workbook? Do you get any error? When you type TRUE in cell B2 does the pdf open? What's in it?