Salt la conținutul principal

Cum să salvați o foaie de lucru ca fișier PDF și să o trimiteți prin e-mail ca atașament prin Outlook?

În unele cazuri, poate fi necesar să trimiteți o foaie de lucru ca fișier PDF prin Outlook. De obicei, trebuie să salvați manual foaia de lucru ca fișier PDF, apoi să creați un e-mail nou cu acest fișier PDF ca atașament în Outlook și apoi să îl trimiteți. Este nevoie de timp pentru ao realiza manual pas cu pas. În acest articol, vă vom arăta cum să salvați rapid o foaie de lucru ca fișier PDF și să o trimiteți automat ca atașament prin Outlook în Excel.

Salvați o foaie de lucru ca fișier PDF și trimiteți-o prin e-mail ca atașament cu cod VBA

Salvați o foaie de lucru ca fișier PDF și trimiteți-o prin e-mail ca atașament cu cod VBA

Puteți rula codul VBA de mai jos pentru a salva automat foaia de lucru activă ca fișier PDF, apoi să o trimiteți prin e-mail ca atașament prin Outlook. Vă rugăm să faceți următoarele.

1. Deschideți foaia de lucru pe care o veți salva ca PDF și trimiteți-o, apoi apăsați pe Alt + F11 tastele simultan pentru a deschide Microsoft Visual Basic pentru aplicații fereastră.

2. În Microsoft Visual Basic pentru aplicații fereastră, faceți clic pe Insera > Module. Apoi copiați și lipiți codul VBA de mai jos în Cod fereastră. Vedeți captura de ecran:

Cod VBA: Salvați o foaie de lucru ca fișier PDF și trimiteți-o prin e-mail ca atașament

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

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 + ".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 = ""
        .CC = ""
        .Subject = xSht.Name + ".pdf"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub

3. apasă pe F5 tasta pentru a rula codul. În Naviga caseta de dialog, selectați un folder pentru a salva acest fișier PDF, apoi faceți clic pe OK butonul.

notițe:

1. Acum foaia de lucru activă este salvată ca fișier PDF. Și fișierul PDF este denumit cu numele foii de lucru.
2. Dacă foaia de lucru activă este goală, veți primi o casetă de dialog, după cum se arată mai jos, după ce faceți clic pe OK butonul.

4. Acum este creat un nou e-mail Outlook și puteți vedea că fișierul PDF este listat ca atașament în fișierul atașat. Vedeți captura de ecran:

5. Vă rugăm să compuneți acest e-mail și apoi să îl trimiteți.
6. Acest cod este disponibil numai atunci când utilizați Outlook ca program de poștă electronică.

Salvați cu ușurință o foaie de lucru sau mai multe foi de lucru ca fișiere PDF separate simultan:

Carnet de lucru divizat utilitatea Kutools pentru Excel vă poate ajuta să salvați cu ușurință o foaie de lucru sau mai multe foi de lucru ca fișiere PDF separate simultan, așa cum se arată în demonstrația de mai jos. Descărcați și încercați acum! (traseu gratuit de 30 de zile)

Articole pe aceeași temă:

Cele mai bune instrumente de productivitate de birou

🤖 Kutools AI Aide: Revoluționați analiza datelor pe baza: Execuție inteligentă   |  Generați codul  |  Creați formule personalizate  |  Analizați datele și generați diagrame  |  Invocați funcțiile Kutools...
Caracteristici populare: Găsiți, evidențiați sau identificați duplicatele   |  Ștergeți rândurile goale   |  Combinați coloane sau celule fără a pierde date   |   Rundă fără Formula ...
Super căutare: VLookup cu mai multe criterii  |   VLookup cu valori multiple  |   VLookup pe mai multe foi   |   Căutare fuzzy ....
Listă derulantă avansată: Creați rapid o listă derulantă   |  Listă drop-down dependentă   |  Listă derulantă cu selectare multiplă ....
Manager de coloane: Adăugați un număr specific de coloane  |  Mutați coloanele  |  Comutați starea vizibilității coloanelor ascunse  |  Comparați intervale și coloane ...
Caracteristici prezentate: Focus pe grilă   |  Vedere de proiectare   |   Big Formula Bar   |  Manager registru de lucru și foi   |  Biblioteca de resurse (Text automat)   |  Data Picker   |  Combinați foi de lucru   |  Criptare/Decriptare celule   |  Trimiteți e-mailuri după listă   |  Super Filtru   |   Filtru special (filtrează bold/italic/barat...) ...
Top 15 seturi de instrumente:  12 Text Instrumente (Adăuga text, Eliminați caractere,...)   |   50+ Diagramă Tipuri de (Gantt Chart,...)   |   40+ Practic Formule (Calculați vârsta pe baza zilei de naștere,...)   |   19 inserare Instrumente (Introduceți codul QR, Inserați imaginea din cale,...)   |   12 Convertire Instrumente (Numere la cuvinte, conversie valutara,...)   |   7 Merge & Split Instrumente (Rânduri combinate avansate, Celule divizate,...)   |   ... și altele

Îmbunătățiți-vă abilitățile Excel cu Kutools pentru Excel și experimentați eficiența ca niciodată. Kutools pentru Excel oferă peste 300 de funcții avansate pentru a crește productivitatea și a economisi timp.  Faceți clic aici pentru a obține funcția de care aveți cea mai mare nevoie...

Descriere

Fila Office aduce interfața cu file în Office și vă face munca mult mai ușoară

  • Activați editarea și citirea cu file în Word, Excel, PowerPoint, Publisher, Access, Visio și Project.
  • Deschideți și creați mai multe documente în filele noi ale aceleiași ferestre, mai degrabă decât în ​​ferestrele noi.
  • Vă crește productivitatea cu 50% și reduce sute de clicuri de mouse pentru dvs. în fiecare zi!
Comments (67)
Rated 5 out of 5 · 1 ratings
Davide
Davide
This comment was minimized by the moderator on the site
Hi guys,
A huge thanks for the code. How can this be amended to use new version of Outlook ?
Reply
0
0
Mayko
Mayko
This comment was minimized by the moderator on the site
Hello, I am a total noob when doing this; so I apologize in advance.

My work has us email them our hours bi weekly, I am based in Arizona US. But I travel for work to Germany. My ADP time management app doesn't work well, given the time difference. So I email my hours, but it's annoying have to type it all every time. So I made a sheet in excel to help me out.
I am using the code posted above to attach pdf attachment to email. But I wanted to add the active sheet in the email body as well. How would I go about it using the same code posted in above. Basically I want to have a button to attach pdf of sheet and in the email body have a screenshot of the same sheet, But I also want my signature below.
I need both options in one button.
(I attached an image of what I mean about screenshot in email body )

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

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 + ".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 = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
Reply
Report
0
0
crystal
crystal     Mayko
This comment was minimized by the moderator on the site
Hi Mayko,
The following VBA code can help you. After running the code, you need to select a folder to save the pdf file. Then, the pdf file will be inserted as an attachment to the email, and a screenshot of the contents of the currently active worksheet and the Outlook signature will be added to the body of the email.


Sub Saveaspdfandsend()
'Updated by Extendoffice 2023/10/19
    Dim xSht As Worksheet
    Dim xFileDlg As FileDialog
    Dim xFolder As String
    Dim xOutlookObj As Object
    Dim xEmailObj As Object
    Dim defaultBodyText 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 & ".pdf"

    'Check if file already exists
    If Len(Dir(xFolder)) > 0 Then
        Dim xYesorNo As Integer
        xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
        If xYesorNo <> vbYes Then
            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
        On Error Resume Next
        Kill xFolder
        On Error GoTo 0
    End If

    '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)
    
    ' Display the email first to ensure signature is loaded
    xEmailObj.Display

    ' Default body text
    defaultBodyText = "<br><br>Dear [Recipient Name],<br><br>Please find attached the requested document.<br><br>Best regards,<br>[Your Name]<br><br>"
    
    ' Update the body while preserving the original (which contains the signature)
    xEmailObj.HTMLBody = defaultBodyText & xEmailObj.HTMLBody

    'Copy the worksheet's content as a picture
    xSht.UsedRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

    'Paste the copied picture to the mail body
    Dim xWordDoc As Object
    Set xWordDoc = xEmailObj.GetInspector.WordEditor
    xWordDoc.Range(0, 0).PasteAndFormat 16 ' 16 is wdChartPicture

    'Add the attachment
    xEmailObj.Attachments.Add xFolder
End Sub
Reply
Report
0
0
Zee
Zee
This comment was minimized by the moderator on the site
I'm using the original post and loving it.
I would like to know how I would be able to set a permanent folder that it downloads the pdf into.
my folder is
G:\BFM\Supervisor\Shift Update Archive

Thankyou
Reply
0
0
crystal
crystal     Zee
This comment was minimized by the moderator on the site
Hi Zee,

The following VBA code can help. Please give it a try. Thank you.
Sub Saveaspdfandsend()
'Updated by Extendoffice 20230130
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

Set xSht = ActiveSheet

xFolder = "G:\BFM\Supervisor\Shift Update Archive" + "\" + xSht.Name + ".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 = ""
        .CC = ""
        .Subject = xSht.Name + ".pdf"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub
Reply
Report
0
0
Cipri
Cipri
This comment was minimized by the moderator on the site
Hi Crystal,

Is it possible to set the pdf name from a specific cell?

Thank you in advance!
Reply
0
0
crystal
crystal     Cipri
This comment was minimized by the moderator on the site
Hi Cipri,
Suppose you want to name the pdf file with the value of A1.
Find the following line in the VBA code:
xFolder = xFolder + "\" + xSht.Name + ".pdf"

Then replace it with the line below.
xFolder = xFolder + "\" + Range("A1") + ".pdf"
Reply
Report
0
0
Cipri
Cipri
This comment was minimized by the moderator on the site
Hi Crystal.

Is there any possibility to save the pdf automatically to a specific folder with the sheet name followed by date and time for example?

I have tried to run one of your codes but it gives me an error at this line

xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

Thank you!
Reply
0
0
crystal
crystal     Cipri
This comment was minimized by the moderator on the site
Hi Cipri,
If you want to save the pdf automatically to a specific folder with the sheet name followed by date and time. The following VBA code can do you a favor.

Sub Saveaspdfandsend()
'Updated by Extendoffice 20220819
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

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 + Format(Now, "dd-mmm-yy h-mm-ss") + ".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 = ""
        .CC = ""
        .Subject = xSht.Name + ".pdf"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub
Reply
Report
0
0
Yousef
Yousef
This comment was minimized by the moderator on the site
Hi,
Many thanks for the code, but can we save a range to PDF.

for example i would like to save a range from B2:Q40 to PDF only?
Reply
0
0
crystal
crystal     Yousef
This comment was minimized by the moderator on the site
Hi,
The following VBA code can do you a favor. Please give it a try.
Sub Saveaspdfandsend()
'Updated by Extendoffice 20220819
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 xWb As Workbook

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 + ".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
Set xUsedRng = xSht.Range("B2:Q40")
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    Application.ScreenUpdating = False
    xUsedRng.Copy
    Set xWb = Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
    Application.DisplayAlerts = False
    xWb.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = ""
        .CC = ""
        .Subject = xSht.Name + ".pdf"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub
Reply
Report
0
0
Jurandir
Jurandir
This comment was minimized by the moderator on the site
Boa tarde,

Conteúdo muito bom mesmo.

É possível criar uma Macro que ao clicar no botão atribuído a essa macro ela envia a planilha automaticamente em PDF para um endereço de e-mail?

Desde já agradeço
Reply
0
0
Rated 5 out of 5
crystal
crystal     Jurandir
This comment was minimized by the moderator on the site
Hi Jurandir,
If you need a button to run the VBA code, please do as follows.
1. Click Develper > Insert > Button (Form Control), then draw a button in a worksheet.
2. After drawing the button, an Assign Macro dialog box pops up, click the New button.
3. Copy the VBA code except the first and last lines, and then paste it between the existing lines in the Code window.
4. Press the Alt + Q keys to close the Code window.
Then you can press the button to run the code.
Reply
Report
0
0
Sudhy
Sudhy
This comment was minimized by the moderator on the site
hi this is working perfectly for me, Can you please help me to do the following along with this Code(1) to save, select the file name from a given cell in the worksheet(2) Automatically add an email address from a cell
Reply
0
0
Rueben
Rueben
This comment was minimized by the moderator on the site
Hi
Thanks for the code but I still having an issue emailing the doc in PDF straight after publishing. This is the current code that I have. I copied the "send email" code from this site.
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xStrName As String

Dim x As Integer
Application.ScreenUpdating = False


' Set numrows = number of rows of data.
NumRows = Worksheets("DATA").Range("A2", Range("A2").End(xlDown)).Rows.Count
' Select cell a1.
Range("A2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
'Reference
Worksheets("Template").Cells(22, 5) = Worksheets("DATA").Cells(x + 1, 2)
'Invoice Number
Worksheets("Template").Cells(22, 7) = Worksheets("DATA").Cells(x + 1, 9)
'Description
Worksheets("Template").Cells(26, 1) = "HANDLING FEE:" & " " & Worksheets("DATA").Cells(x + 1, 6)
'Amounts
Worksheets("Template").Cells(26, 9) = Worksheets("DATA").Cells(x + 1, 4)

' Insert your code here.
' Selects cell down 1 row from active cell.
' ActiveCell.Offset(1, 0).Select
Set wbA = ActiveWorkbook
Set wsA = Worksheets("Template")


'get active workbook folder, if saved
' On Error GoTo errHandler
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
Application.ScreenUpdating = True
strName = wsA.Range("L1").Value _
& " - " & wsA.Range("A2").Value _
& " - " & wsA.Range("A3").Value

'create default name for savng file
strFile = strName & ".pdf"
strPathFile = strPath & strFile

'export to PDF in current folder
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strPathFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
' MsgBox "PDF file has been created: " _
' & vbCrLf _
' & strPathFile

' Create Outlook email

Set OutMail = OutApp.CreateItem(0)

strMsg = "Could not start mail for " _
& c.Value
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = strSubj
.Body = strBody
.Attachments.Add _
strSavePath & strPDFName
.Send
End With
On Error GoTo 0
lSent = lSent + 1
If lSent >= lCount Then Exit For


MsgBox "The active worksheet cannot be blank"
Exit Sub


exitHandler:
' Set wsA = Worksheets("Template")
'errHandler:
' MsgBox "Could not create PDF file"
' Resume exitHandler


Next
End Sub



Reply
Report
0
0
Rod Bennett
Rod Bennett
This comment was minimized by the moderator on the site
Hi
Many thanks for the Code but is it possible to save the the PDF automatically to the same location as the active Excel file and with the same file name as the active Excel file?
Many thanks.
Rod
Reply
0
0
There are no comments posted here yet
Load More
Please leave your comments in English
Guest
Posting as Guest
×
Rate this post:
Reset
0   Characters
Suggested Locations