Code that will prompt for a folder and create the file name from data in a cell+

  • Hello team
    I have code that works well to take a spreadsheet, export to a PDF, however it prompts for a folder first and then creates the file name from a combination of data in a cell and code in the string. In the middle of all that, it will see if the file already exists and ask to overwrite it or not.


    What Im trying to do now is all the same but end up with a .XLS file, not a PDF. Not a pro-coder but with the great help of places like this I get what I need, but in this case after days of trying I fail! Advice would be very much appreciated. Here's the code I have to start with:


    [SIZE=9px]Sub Quote()


    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 = ""



    ' Note: lock date
    Sheets("Sheet1").Select
    Range("a3").Select
    ActiveCell.FormulaR1C1 = "=TODAY()"
    Range("a3").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Sheets("sheet1").Select



    'Prompt for file destination
    With Application.FileDialog(msoFileDialogFolderPicker)
    MsgBox "Specify a folder to save this Proposal", vbInformation, "Specify Destination Folder"
    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


    'Current month/year stored in H6 (this is a merged cell)
    'CurrentMonth = Mid(ActiveSheet.Range("k5").Value, InStr(1, ActiveSheet.Range("k5").Value, " ") + 1)

    'Create new PDF file name including path and file extension
    'PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
    & "_" & CurrentMonth & ".pdf"
    PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Range("b7").Value _
    & "_" & Format(Date, "yyyymmdd") & ".pdf"


    'If the PDF already exists
    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 you want to overwrite the file then delete the current one
    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.", 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


    'Create the PDF
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
    :=False, OpenAfterPublish:=OpenPDFAfterCreating



    End Sub[/SIZE]

Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!