Saving a sheet in TWO formats

cgmboto

New Member
Joined
Jan 20, 2022
Messages
2
Office Version
  1. 2013
Platform
  1. Windows
Hello guys

I have used the code below to save a sheet as PDF and then send with Outlook. But I am wondering if it's possible to save the sheet to BOTH *.pdf og *.xls file in the same directory? Is here anyone who can help me to find a solution ? :- )

Thanks in advance and have a nice day!

VBA Code:
Option Explicit

Sub Rykker_efter_lejeloven_Tørring()
' Author - Philip Treacy  ::   http://www.linkedin.com/in/philiptreacy
' http://www.MyOnlineTrainingHub.com/vba-to-create-pdf-from-excel-worksheet-then-email-it-with-outlook
' Date - 14 Oct 2013
' Create a PDF from the current sheet and email it as an attachment through Outlook

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 = ""
Dim Signature As Variant


' *****************************************************
' *****     You Can Change These Variables    *********

    EmailSubject = "TEKST" & ActiveSheet.Range("A11") & ", " & ActiveSheet.Range("A12")   'Change this to change the subject of the email. The current month is added to end of subj line
    OpenPDFAfterCreating = False    'Change this if you want to open the PDF after creating it : TRUE or FALSE
    AlwaysOverwritePDF = True      'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE
    DisplayEmail = True 'Change this if you don't want to display the email before sending.  Note, you must have a TO email address specified for this to work
    Email_To = ActiveSheet.Range("A14")   'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
    Email_CC = ActiveSheet.Range("A15")
    Email_BCC = ""
           
' ******************************************************
    
    'Prompt for file destination
    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

     
    'Create new PDF file name including path and file extension
    PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Range("J1") & " " & "TEKST - " & ActiveSheet.Range("A11") & ActiveSheet.Range("A10") & ".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 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
   

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

    '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
      .HTMLBody = x
















        .Attachments.Add PDFFile
                
        If DisplayEmail = False Then
            
            .Send
            
        End If
        
    End With
    
 
End Sub
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
yes, run Export on all formats:

'pdf
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\temp\Book1.pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True

'xls
ActiveWorkbook.SaveAs Filename:="C:\temp\Book1.xlsx", FileFormat:=xlOpenXMLWorkbook
 
Upvote 0
yes, run Export on all formats:

'pdf
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\temp\Book1.pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True

'xls
ActiveWorkbook.SaveAs Filename:="C:\temp\Book1.xlsx", FileFormat:=xlOpenXMLWorkbook

But with this code it is not possible to choose the location for the file in popup window. It must be written in the code.
 
Upvote 0

Forum statistics

Threads
1,223,237
Messages
6,170,924
Members
452,366
Latest member
TePunaBloke

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top