Note: The other languages of the website are Google-translated. Back to English

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! (30- traseu liber de o zi)


Articole pe aceeași temă:


Cele mai bune instrumente de productivitate Office

Kutools pentru Excel vă rezolvă majoritatea problemelor și vă crește productivitatea cu 80%

  • reutilizarea: Introduceți rapid formule complexe, diagrame și orice ai folosit anterior; Criptați celulele cu parola; Creați o listă de corespondență și trimiteți e-mailuri ...
  • Super Formula Bar (editați cu ușurință mai multe linii de text și formulă); Layout de citire (citiți și editați cu ușurință un număr mare de celule); Lipiți la interval filtrat...
  • Merge celule / rânduri / coloane fără a pierde date; Conținut de celule divizate; Combinați rânduri / coloane duplicate... Prevenirea celulelor duplicate; Comparați gamele...
  • Selectați Duplicat sau Unic Rânduri; Selectați Rânduri goale (toate celulele sunt goale); Super Find și Fuzzy Find în multe cărți de lucru; Selectare aleatorie ...
  • Copie exactă Mai multe celule fără modificarea referinței formulelor; Creați automat referințe la foi multiple; Introduceți gloanțe, Casete de selectare și multe altele ...
  • Extrageți textul, Adăugați text, eliminați după poziție, Eliminați spațiul; Creați și imprimați subtotaluri de paginare; Convertiți conținutul dintre celule și comentarii...
  • Super Filtru (salvați și aplicați scheme de filtrare altor foi); Sortare avansată după lună / săptămână / zi, frecvență și multe altele; Filtru special cu bold, italic ...
  • Combinați cărți de lucru și foi de lucru; Merge Tables pe baza coloanelor cheie; Împărțiți datele în mai multe foi; Conversia în loturi xls, xlsx și PDF...
  • Peste 300 de funcții puternice. Suportă Office / Excel 2007-2021 și 365. Acceptă toate limbile. Implementare ușoară în întreprinderea sau organizația dvs. Funcții complete Probă gratuită de 30 de zile. Garanție de returnare a banilor de 60 de zile.
fila kte 201905

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!
fundul officetab
Comentarii (63)
Evaluat 5 din 5 · evaluări 1
Acest comentariu a fost redus la minimum de moderatorul de pe site
Acest lucru funcționează grozav pentru mine, dar există o modalitate de a selecta automat o locație de folder în loc să o selectez manual? Sper să fac asta pentru 40 de coli deodată.
Acest comentariu a fost redus la minimum de moderatorul de pe site
De asemenea, sper să văd un răspuns pentru această problemă! Multumesc pentru ajutor!
Acest comentariu a fost redus la minimum de moderatorul de pe site
Am încercat să lipesc acest lucru într-un modul nou și primesc eroare de compilare: Sub sau Funcție nu este definită. Te rog ajuta-ma.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Dragă Darren,
Ce versiune de Office folosești?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Oficiul pentru 360
Acest comentariu a fost redus la minimum de moderatorul de pe site
Aceeași problemă
Acest comentariu a fost redus la minimum de moderatorul de pe site
Cum aș edita scriptul VBA de mai sus, astfel încât să adauge o ștampilă de dată și oră la numele fișierului, astfel încât să nu continue să suprascrie ceea ce este deja salvat?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Dragă Michael,
Rulați codul VBA de mai jos pentru a rezolva problema.

Sub Saveaspdfandsend()
Dim xSht ca foaie de lucru
Dim xFileDlg ca FileDialog
Dim xFolder ca șir
Dim xYesorNo ca întreg
Dim xOutlookObj ca obiect
Dim xEmailObj ca obiect
Dim xUsedRng As Range
Dim xStr As String

Setați xSht = ActiveSheet
Setați xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

Dacă xFileDlg.Show = Adevărat, atunci
xFolder = xFileDlg.SelectedItems(1)
Altfel
MsgBox „Trebuie să specificați un folder în care să salvați PDF-ul”. & vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Trebuie să specificați folderul de destinație”
Ieșiți din Sub
Final, dacă
xStr = Format(Acum(), "aaaa-mm-zz-hh-mm-ss")
xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".pdf"

„Verificați dacă fișierul există deja
Dacă Len(Dir(xFolder)) > 0, atunci
xYesorNo = MsgBox(xFolder & „există deja.” & vbCrLf & vbCrLf & „Doriți să-l suprascrieți?”, _
vbYesNo + vbÎntrebare, „Fișierul există”)
La data de eroare CV următoare
Dacă xDa sauNu = vbDa Atunci
Omorâți xFolder
Altfel
MsgBox „dacă nu suprascrii PDF-ul existent, nu pot continua.” _
& vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Ieșire din macrocomandă”
Ieșiți din Sub
Final, dacă
Dacă Err.Number <> 0 Atunci
MsgBox „Nu se poate șterge fișierul existent. Asigurați-vă că fișierul nu este deschis sau protejat la scriere.” _
& vbCrLf & vbCrLf & „Apăsați pe OK pentru a ieși din această macrocomandă.”, vbCritical, „Nu se poate șterge fișierul”
Ieșiți din Sub
Final, dacă
Final, dacă

Setați xUsedRng = xSht.UsedRange
Dacă Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Atunci
„Salvați ca fișier PDF
xSht.ExportAsFixedFormat Tip:=xlTypePDF, Nume fișier:=xFolder, Quality:=xlQualityStandard

„Creează e-mail Outlook
Setați xOutlookObj = CreateObject("Outlook.Application")
Setați xEmailObj = xOutlookObj.CreateItem(0)
Cu xEmailObj
.Afişa
.To = ""
.CC = ""
.Subiect = xSht.Name + "-" + xStr + ".pdf"
.Atașamente.Adăugați xFolder
Dacă DisplayEmail = False, atunci
'.Trimite
Final, dacă
Se termina cu
Altfel
MsgBox „Foaia de lucru activă nu poate fi goală”
Ieșiți din Sub
Final, dacă
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Salut Crystal,

Este cu adevărat grozav și funcționează perfect pentru mine. Aveți nevoie de mai mult ajutor pentru a adăuga:

1. în „Către” vreau să dau link către o anumită celulă a foii active, cum ar fi în CC și în BCC, aș dori să adaug linkul pentru foaia activă
2. în corpul e-mailului trebuie să specific un text standard.

Îți voi fi foarte plin pentru ajutorul tău.

mulțumesc
paragraf
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună Parag Somani,
Codul VBA de mai jos vă poate ajuta. Vă rugăm să modificați câmpurile .To, .CC, .BCC și .Body în funcție de nevoile dvs.

Sub Saveaspdfandsend()
Dim xSht ca foaie de lucru
Dim xFileDlg ca FileDialog
Dim xFolder ca șir
Dim xYesorNo ca întreg
Dim xOutlookObj ca obiect
Dim xEmailObj ca obiect
Dim xUsedRng As Range
Dim xStr As String

Setați xSht = ActiveSheet
Setați xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

Dacă xFileDlg.Show = Adevărat, atunci
xFolder = xFileDlg.SelectedItems(1)
Altfel
MsgBox „Trebuie să specificați un folder în care să salvați PDF-ul”. & vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Trebuie să specificați folderul de destinație”
Ieșiți din Sub
Final, dacă
xStr = Format(Acum(), "aaaa-mm-zz-hh-mm-ss")
xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".pdf"

„Verificați dacă fișierul există deja
Dacă Len(Dir(xFolder)) > 0, atunci
xYesorNo = MsgBox(xFolder & „există deja.” & vbCrLf & vbCrLf & „Doriți să-l suprascrieți?”, _
vbYesNo + vbÎntrebare, „Fișierul există”)
La data de eroare CV următoare
Dacă xDa sauNu = vbDa Atunci
Omorâți xFolder
Altfel
MsgBox „dacă nu suprascrii PDF-ul existent, nu pot continua.” _
& vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Ieșire din macrocomandă”
Ieșiți din Sub
Final, dacă
Dacă Err.Number <> 0 Atunci
MsgBox „Nu se poate șterge fișierul existent. Asigurați-vă că fișierul nu este deschis sau protejat la scriere.” _
& vbCrLf & vbCrLf & „Apăsați pe OK pentru a ieși din această macrocomandă.”, vbCritical, „Nu se poate șterge fișierul”
Ieșiți din Sub
Final, dacă
Final, dacă

Setați xUsedRng = xSht.UsedRange
Dacă Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Atunci
„Salvați ca fișier PDF
xSht.ExportAsFixedFormat Tip:=xlTypePDF, Nume fișier:=xFolder, Quality:=xlQualityStandard

„Creează e-mail Outlook
Setați xOutlookObj = CreateObject("Outlook.Application")
Setați xEmailObj = xOutlookObj.CreateItem(0)
Cu xEmailObj
.Afişa
.To = Range("A8")
.CC = Interval(„A9”)
.BCC = Interval(„A10”)
.Subiect = xSht.Name + "-" + xStr + ".pdf"
.Body = „Dragă” _
& vbNewLine & vbNewLine & _
„Acesta este un e-mail de test” & _
"trimitere in Excel"
.Atașamente.Adăugați xFolder
Dacă DisplayEmail = False, atunci
'.Trimite
Final, dacă
Se termina cu
Altfel
MsgBox „Foaia de lucru activă nu poate fi goală”
Ieșiți din Sub
Final, dacă
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Am încercat să folosesc Intervalul pentru „To”, „CC”, pur și simplu nu preia valorile din celula desemnată. Vă rog, puteți ajuta la asta?
Multumesc,
Mehul
Acest comentariu a fost redus la minimum de moderatorul de pe site
Salut Crystal,

Este cu adevărat grozav și funcționează perfect pentru mine. Aveți nevoie de mai mult ajutor pentru a adăuga:

1. în „Către” vreau să dau link către o anumită celulă a foii active, cum ar fi în CC și în BCC, aș dori să adaug linkul pentru foaia activă
2. în corpul e-mailului trebuie să specific un text standard.

Îți voi fi foarte plin pentru ajutorul tău.

mulțumesc
paragraf
Acest comentariu a fost redus la minimum de moderatorul de pe site
Salut Crystal,

Este cu adevărat grozav și funcționează perfect pentru mine. Aveți nevoie de mai mult ajutor pentru a adăuga:

1. în „Către” vreau să dau link către o anumită celulă a foii active, cum ar fi în CC și în BCC, aș dori să adaug linkul pentru foaia activă
2. în corpul e-mailului trebuie să specific un text standard.

Îți voi fi foarte plin pentru ajutorul tău.

mulțumesc
paragraf
Acest comentariu a fost redus la minimum de moderatorul de pe site
Cum pot adăuga, de exemplu, foaia 2 din registrul de lucru ca pdf?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Buna Armin,
Mai întâi trebuie să deschideți foaia 2 din registrul de lucru și apoi să rulați codul VBA cu pașii de mai sus pentru a-l debarasa.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Cum aș edita scriptul VBA de mai sus, astfel încât numele fișierului să fie salvat ca o anumită celulă selectată în foaia curentă, de exemplu celula A1?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Salut, Tom.
Îmi pare rău, nu te pot ajuta cu asta.
Bine ați venit să postați orice întrebare pe forumul nostru: https://www.extendoffice.com/forum.html
Veți primi mai mult suport Excel de la profesioniștii Excel sau de la alți fani Excel.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună, cum pot salva și trimite pdf-ul cu numele registrului de lucru cu codul VBA actual? ce folosesc în loc de xSht.Name
Acest comentariu a fost redus la minimum de moderatorul de pe site
Hi James,
Doriți să trimiteți foaia de lucru activă ca pdf și să o denumiți ca nume registrului de lucru?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Mulțumesc, funcționează.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Cum îl pot face să șteargă pdf-ul salvat după ce îl trimite prin e-mail?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Hi Jason,
Îmi pare rău că nu te pot ajuta încă cu asta. Trebuie să îl ștergeți manual după ce îl trimiteți prin e-mail.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Buna,

Este posibil să găsiți numele pentru pdf dintr-o celulă? Ex. Celula H4


Și în celula H4 vreau să se colecteze din trei celule diferite. Este posibil?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Este posibil. Faceți variabile separate pentru a păstra valoarea din celule și apoi utilizați acele variabile când setați xFolder.
Am folosit valoarea dintr-o celulă din foaia mea plus data de astăzi. Totuși, puteți face cu ușurință mai multe valori de celule.

Iată ce am adăugat:
Dim xMemberName ca șir
Dim xFileDate ca șir

xMemberName = Range("H3").Value
xFileDate = Format(Acum, „mm-dd”)

xFolder = xFolder + „\” xMemberName + xFileDate + „.pdf”
Acest comentariu a fost redus la minimum de moderatorul de pe site
Primesc o eroare când încerc asta, unde ar trebui să plasez asta în cod?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Salut Crystal,



Este cu adevărat grozav și funcționează perfect pentru mine. Aveți nevoie de mai mult ajutor pentru a adăuga:

1. în „Corps” vreau să dau link către o anumită celulă a foii active. Mai mult Aș dori să pun textul îngroșat.

mulțumesc

În ceea ce priveşte

Kishore kumar
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună,

Vrei să adaugi automat valoarea celulei în corpul e-mailului și să o îndrăznești? Să presupunem că adăugați valoarea lui C4 la corpul e-mailului. Vă rugăm să aplicați codul de mai jos.

Sub Saveaspdfandsend()

Dim xSht ca foaie de lucru

Dim xFileDlg ca FileDialog

Dim xFolder ca șir

Dim xYesorNo ca întreg

Dim xOutlookObj ca obiect

Dim xEmailObj ca obiect

Dim xUsedRng As Range



Setați xSht = ActiveSheet

Setați xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)



Dacă xFileDlg.Show = Adevărat, atunci

xFolder = xFileDlg.SelectedItems(1)

Altfel

MsgBox „Trebuie să specificați un folder în care să salvați PDF-ul”. & vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Trebuie să specificați folderul de destinație”

Ieșiți din Sub

Final, dacă

xFolder = xFolder + „\” + xSht.Name + „.pdf”



„Verificați dacă fișierul există deja

Dacă Len(Dir(xFolder)) > 0, atunci

xYesorNo = MsgBox(xFolder & „există deja.” & vbCrLf & vbCrLf & „Doriți să-l suprascrieți?”, _

vbYesNo + vbÎntrebare, „Fișierul există”)

La data de eroare CV următoare

Dacă xDa sauNu = vbDa Atunci

Omorâți xFolder

Altfel

MsgBox „dacă nu suprascrii PDF-ul existent, nu pot continua.” _

& vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Ieșire din macrocomandă”

Ieșiți din Sub

Final, dacă

Dacă Err.Number <> 0 Atunci

MsgBox „Nu se poate șterge fișierul existent. Asigurați-vă că fișierul nu este deschis sau protejat la scriere.” _

& vbCrLf & vbCrLf & „Apăsați pe OK pentru a ieși din această macrocomandă.”, vbCritical, „Nu se poate șterge fișierul”

Ieșiți din Sub

Final, dacă

Final, dacă



Setați xUsedRng = xSht.UsedRange

Dacă Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Atunci

„Salvați ca fișier PDF

xSht.ExportAsFixedFormat Tip:=xlTypePDF, Nume fișier:=xFolder, Quality:=xlQualityStandard



„Creează e-mail Outlook

Setați xOutlookObj = CreateObject("Outlook.Application")

Setați xEmailObj = xOutlookObj.CreateItem(0)

Cu xEmailObj

.Afişa

.To = ""

.CC = ""

.Subiect = xSht.Name + „.pdf”

.Atașamente.Adăugați xFolder

.HTMLBody = "
" & Range("C4") & .HTMLBody

Dacă DisplayEmail = False, atunci

'.Trimite

Final, dacă

Se termina cu

Altfel

MsgBox „Foaia de lucru activă nu poate fi goală”

Ieșiți din Sub

Final, dacă

End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Dacă aș dori să se salveze automat într-un folder specific de fiecare dată (eliminând nevoia ca utilizatorul să aleagă folderul), cum aș face asta?
Ex. C: Facturi/America de Nord/Clienți
Ajutorul este foarte apreciat.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună Geoff,
Adică salvați foaia de lucru ca fișier pdf și salvați într-un anumit folder fără a trimite?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Cred că Geoff înseamnă a putea specifica un anumit folder în codul în care este salvat pdf-ul de fiecare dată, mai degrabă decât a fi nevoit să selectezi manual locația. pdf-ul este apoi trimis prin e-mail din acel folder specific.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Mulțumesc Jeremy.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună Geoff, Dacă doriți să salvați automat fișierul pdf într-un folder specific, în loc să selectați locația manual, vă rugăm să încercați codul de mai jos. Nu uitați să schimbați calea folderului în cod.
Sub SaveAsPDFandSend()
Dim xSht ca foaie de lucru
Dim xFileDlg ca FileDialog
Dim xFolder ca șir
Dim xYesorNo ca întreg
Dim xOutlookObj ca obiect
Dim xEmailObj ca obiect
Dim xUsedRng As Range
Dim xPath ca șir
Setați xSht = ActiveSheet
xPath = "C:\Users\Win10x64Test\Desktop\worksheet în pdf" "aici "worksheet to pdf" este folderul de destinație pentru salvarea fișierelor pdf
xFolder = xPath + „\” + xSht.Name + „.pdf”
Dacă Len(Dir(xFolder)) > 0, atunci
xYesorNo = MsgBox(xFolder & „există deja.” & vbCrLf & vbCrLf & „Doriți să-l suprascrieți?”, _
vbYesNo + vbÎntrebare, „Fișierul există”)
La data de eroare CV următoare
Dacă xDa sauNu = vbDa Atunci
Omorâți xFolder
Altfel
MsgBox „dacă nu suprascrii PDF-ul existent, nu pot continua.” _
& vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Ieșire din macrocomandă”
Ieșiți din Sub
Final, dacă
Dacă Err.Number <> 0 Atunci
MsgBox „Nu se poate șterge fișierul existent. Asigurați-vă că fișierul nu este deschis sau protejat la scriere.” _
& vbCrLf & vbCrLf & „Apăsați pe OK pentru a ieși din această macrocomandă.”, vbCritical, „Nu se poate șterge fișierul”
Ieșiți din Sub
Final, dacă
Final, dacă

Setați xUsedRng = xSht.UsedRange
Dacă Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Atunci
„Salvați ca fișier PDF
xSht.ExportAsFixedFormat Tip:=xlTypePDF, Nume fișier:=xFolder, Quality:=xlQualityStandard

„Creează e-mail Outlook
Setați xOutlookObj = CreateObject("Outlook.Application")
Setați xEmailObj = xOutlookObj.CreateItem(0)
Cu xEmailObj
.Afişa
.To = ""
.CC = ""
.Subiect = xSht.Name + „.pdf”
.Atașamente.Adăugați xFolder
Dacă DisplayEmail = False, atunci
'.Trimite
Final, dacă
Se termina cu
Altfel
MsgBox „Foaia de lucru activă nu poate fi goală”
Ieșiți din Sub
Final, dacă
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Acest cod funcționează excelent, cu excepția faptului că vreau ca foaia de lucru să fie salvată ca nume foii + dată (adică Sheet1 Oct 1 2020); pe desktopul utilizatorului (aceasta va fi folosită de mai multe persoane, iar căile acestora pot varia ușor). Dacă este posibil, vreau să încorporez un .jpg și în corp.. JPG-ul este situat atât în ​​interiorul foii de lucru (în afara zonei de imprimare), cât și imaginea este stocată pe un server partajat.. deși calea către server variază în funcție de utilizator (pentru majoritatea este o unitate „T” pentru unii o unitate „U”)
se poate face asta? va rog si va multumesc de un milion de ori.
Acest comentariu a fost redus la minimum de moderatorul de pe site

Bună, funcționează foarte bine, mulțumesc pentru împărtășire. Am nevoie doar de un ajutor.
Dacă vreau să salvez un fișier PDF cu nume personalizat (opțiune de a introduce numele fișierului în caseta de dialog Salvare ca), ca utilizator, utilizați această opțiune în șablonul de formular unde formularele sunt salvate ca PDF cu nume unic .
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună, Vă rugăm să încercați codul VBA de mai jos. După rularea codului, selectați un folder pentru a salva fișierul PDF, apoi va apărea o casetă de dialog pentru a introduce numele fișierului. Sub Saveaspdfandsend()
„Actualizat de Extendoffice 20210209
Dim xSht ca foaie de lucru
Dim xFileDlg ca FileDialog
Dim xFolder ca șir
Dim xYesorNo ca întreg
Dim xOutlookObj ca obiect
Dim xEmailObj ca obiect
Dim xUsedRng As Range
Dim xStrName ca șir
Dim xV ca variantă

Setați xSht = ActiveSheet
Setați xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

Dacă xFileDlg.Show = Adevărat, atunci
xFolder = xFileDlg.SelectedItems(1)
Altfel
MsgBox „Trebuie să specificați un folder în care să salvați PDF-ul”. & vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Trebuie să specificați folderul de destinație”
Ieșiți din Sub
Final, dacă
xStrName = ""
xV = Application.InputBox(„Vă rugăm să introduceți numele fișierului:”, „Kutools pentru Excel”, , , , , , 2)
Dacă xV = Fals, atunci
Ieșiți din Sub
Final, dacă
xStrName = xV
Dacă xStrName = "" Atunci
MsgBox ("Nu s-a introdus niciun nume de fișier, se iese din proces!")
Ieșiți din Sub
Final, dacă

xFolder = xFolder + „\” + xStrName + „.pdf”
„Verificați dacă fișierul există deja
Dacă Len(Dir(xFolder)) > 0, atunci
xYesorNo = MsgBox(xFolder & „există deja.” & vbCrLf & vbCrLf & „Doriți să-l suprascrieți?”, _
vbYesNo + vbÎntrebare, „Fișierul există”)
La data de eroare CV următoare
Dacă xDa sauNu = vbDa Atunci
Omorâți xFolder
Altfel
MsgBox „dacă nu suprascrii PDF-ul existent, nu pot continua.” _
& vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Ieșire din macrocomandă”
Ieșiți din Sub
Final, dacă
Dacă Err.Number <> 0 Atunci
MsgBox „Nu se poate șterge fișierul existent. Asigurați-vă că fișierul nu este deschis sau protejat la scriere.” _
& vbCrLf & vbCrLf & „Apăsați pe OK pentru a ieși din această macrocomandă.”, vbCritical, „Nu se poate șterge fișierul”
Ieșiți din Sub
Final, dacă
Final, dacă

Setați xUsedRng = xSht.UsedRange
Dacă Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Atunci
„Salvați ca fișier PDF
xSht.ExportAsFixedFormat Tip:=xlTypePDF, Nume fișier:=xFolder, Quality:=xlQualityStandard

„Creează e-mail Outlook
Setați xOutlookObj = CreateObject("Outlook.Application")
Setați xEmailObj = xOutlookObj.CreateItem(0)
Cu xEmailObj
.Afişa
.To = ""
.CC = ""
.Subiect = xSht.Name + „.pdf”
.Atașamente.Adăugați xFolder
Dacă DisplayEmail = False, atunci
'.Trimite
Final, dacă
Se termina cu
Altfel
MsgBox „Foaia de lucru activă nu poate fi goală”
Ieșiți din Sub
Final, dacă
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună,
Dacă am două foi în fișier și aș dori să rulez această macrocomandă pe o singură foaie (prin apăsarea butonului) dar trimit alta, cum o pot obține?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună ziua, aș dori să salvez acest lucru într-o anumită locație a fișierului, cu numele bazat pe valoarea din celula C30. Am încercat câteva opțiuni, dar continuă să primesc defecte.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună hein, codul de mai jos poate te poate ajuta. După ce rulați codul, selectați un anumit folder pentru a salva fișierul PDF, apoi va apărea o casetă de dialog pentru a introduce numele fișierului. Sub Saveaspdfandsend()
„Actualizat de Extendoffice 20210209
Dim xSht ca foaie de lucru
Dim xFileDlg ca FileDialog
Dim xFolder ca șir
Dim xYesorNo ca întreg
Dim xOutlookObj ca obiect
Dim xEmailObj ca obiect
Dim xUsedRng As Range
Dim xStrName ca șir
Dim xV ca variantă

Setați xSht = ActiveSheet
Setați xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

Dacă xFileDlg.Show = Adevărat, atunci
xFolder = xFileDlg.SelectedItems(1)
Altfel
MsgBox „Trebuie să specificați un folder în care să salvați PDF-ul”. & vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Trebuie să specificați folderul de destinație”
Ieșiți din Sub
Final, dacă
xStrName = ""
xV = Application.InputBox(„Vă rugăm să introduceți numele fișierului:”, „Kutools pentru Excel”, , , , , , 2)
Dacă xV = Fals, atunci
Ieșiți din Sub
Final, dacă
xStrName = xV
Dacă xStrName = "" Atunci
MsgBox ("Nu s-a introdus niciun nume de fișier, se iese din proces!")
Ieșiți din Sub
Final, dacă

xFolder = xFolder + „\” + xStrName + „.pdf”
„Verificați dacă fișierul există deja
Dacă Len(Dir(xFolder)) > 0, atunci
xYesorNo = MsgBox(xFolder & „există deja.” & vbCrLf & vbCrLf & „Doriți să-l suprascrieți?”, _
vbYesNo + vbÎntrebare, „Fișierul există”)
La data de eroare CV următoare
Dacă xDa sauNu = vbDa Atunci
Omorâți xFolder
Altfel
MsgBox „dacă nu suprascrii PDF-ul existent, nu pot continua.” _
& vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Ieșire din macrocomandă”
Ieșiți din Sub
Final, dacă
Dacă Err.Number <> 0 Atunci
MsgBox „Nu se poate șterge fișierul existent. Asigurați-vă că fișierul nu este deschis sau protejat la scriere.” _
& vbCrLf & vbCrLf & „Apăsați pe OK pentru a ieși din această macrocomandă.”, vbCritical, „Nu se poate șterge fișierul”
Ieșiți din Sub
Final, dacă
Final, dacă

Setați xUsedRng = xSht.UsedRange
Dacă Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Atunci
„Salvați ca fișier PDF
xSht.ExportAsFixedFormat Tip:=xlTypePDF, Nume fișier:=xFolder, Quality:=xlQualityStandard

„Creează e-mail Outlook
Setați xOutlookObj = CreateObject("Outlook.Application")
Setați xEmailObj = xOutlookObj.CreateItem(0)
Cu xEmailObj
.Afişa
.To = ""
.CC = ""
.Subiect = xSht.Name + „.pdf”
.Atașamente.Adăugați xFolder
Dacă DisplayEmail = False, atunci
'.Trimite
Final, dacă
Se termina cu
Altfel
MsgBox „Foaia de lucru activă nu poate fi goală”
Ieșiți din Sub
Final, dacă
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Mulțumesc pentru asta, este grozav, dar vreau ca foaia să fie numită conform celulei A1 de pe foaia 1. Locul de salvare conform A1 din foaia 2, de exemplu C:\Users\peete\Dropbox\Screenshots, iar e-mailul se trimite la adresa de e-mail de pe foaia A3 2 ceea ce am rezolvat deja.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Mulțumesc pentru asta, este grozav, dar vreau ca foaia să fie numită conform celulei A1 de pe foaia 1. locul de salvare conform A1 de pe foaia 2, de exemplu C:\Users\peete\Dropbox\Screenshots, dar se poate schimba când folosind fișierul și trimite e-mail la adresa de e-mail de pe foaia A3 2 ceea ce am rezolvat deja.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Hi cristal , cod excelent, mulțumesc pentru partajare. Există o modalitate de a selecta mai multe foi (din același registru de lucru) pentru a le salva pe fiecare ca PDF independent și apoi a le trimite pe toate atașate într-un singur e-mail?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună, Codul VBA de mai jos vă poate face o favoare, vă rugăm să încercați. În a douăsprezecea linie a codului, înlocuiți numele foilor cu numele foilor reale în cazul dvs.
Sub Saveaspdfandsend1()
Dim xSht ca foaie de lucru
Dim xFileDlg ca FileDialog
Dim xFolder ca șir
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj ca obiect
Dim xEmailObj ca obiect
Dim xUsedRng As Range
Dim xArrShetts ca variantă
Dim xPDFNameAddress ca șir
Dim xStr As String
xArrShetts = Matrice("Test", „Foaie 1”, „Foaie 2”) „Introduceți numele foilor pe care le veți trimite sub formă de fișiere pdf închise cu ghilimele și separați-le prin virgulă. Asigurați-vă că nu există caractere speciale, cum ar fi \/:"*<>| în numele fișierului.

Pentru I = 0 La UBound(xArrShetts)
La data de eroare CV următoare
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
Dacă xSht.Name <> xArrShetts(I) Atunci
MsgBox „Foaia de lucru nu a fost găsită, operațiune de ieșire:” & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, „Kutools pentru Excel”
Ieșiți din Sub
Final, dacă
Pagina Următoare →


Setați xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Dacă xFileDlg.Show = Adevărat, atunci
xFolder = xFileDlg.SelectedItems(1)
Altfel
MsgBox „Trebuie să specificați un folder în care să salvați PDF-ul”. & vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Trebuie să specificați folderul de destinație”
Ieșiți din Sub
Final, dacă
„Verificați dacă fișierul există deja
xYesorNo = MsgBox(„Dacă fișierele cu același nume există în folderul de destinație, sufixul numeric va fi adăugat automat la numele fișierului pentru a distinge duplicatele” & vbCrLf & vbCrLf & „Faceți clic pe Da pentru a continua, faceți clic pe Nu pentru a anula”, _
vbYesNo + vbÎntrebare, „Fișierul există”)
Dacă xDasauNu <> vbDa, atunci Ieșiți din sub
Pentru I = 0 La UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))

xStr = xFolder & „\” & xSht.Name & „.pdf”
xNum = 1
În timp ce nu (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Merge încet
Setați xUsedRng = xSht.UsedRange
Dacă Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Atunci
xSht.ExportAsFixedFormat Type:=xlTypePDF, Nume fișier:=xStr, Quality:=xlQualityStandard
Altfel

Final, dacă
xArrShetts(I) = xStr
Pagina Următoare →

„Creează e-mail Outlook
Setați xOutlookObj = CreateObject("Outlook.Application")
Setați xEmailObj = xOutlookObj.CreateItem(0)
Cu xEmailObj
.Afişa
.To = ""
.CC = ""
.Subiect = "????"
Pentru I = 0 La UBound(xArrShetts)
.Atașamente.Adăugați xArrShetts(I)
Pagina Următoare →
Dacă DisplayEmail = False, atunci
'.Trimite
Final, dacă
Se termina cu
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună, Singura modificare cu care mă confrunt este să creez un e-mail separat pentru fiecare document pdf creat.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună, Pentru a crea un e-mail separat pentru fiecare document pdf, puteți rula manual VBA furnizat în postare în diferite foi de lucru pentru a finaliza.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Am mai mult de 100 de foi de lucru în registrul de lucru, ceea ce înseamnă că trebuie să rulez VBA de mai mult de 100 de ori, ceea ce necesită mult timp.  
Am reușit să-mi împart registrul de lucru în mai multe foi și apoi pot converti fiecare foaie de lucru într-un document PDF individual.
Soluția pe care o caut este să trimit prin e-mail fiecare document PDF separat în timp ce procesul de mai sus se desfășoară.
Cu aici VBA-ul pe care îl rulez în prezent:
Sub Saveaspdfandsend1()
Dim xSht ca foaie de lucru
Dim xFileDlg ca FileDialog
Dim xFolder ca șir
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj ca obiect
Dim xEmailObj ca obiect
Dim xUsedRng As Range
Dim xArrShetts ca variantă
Dim xPDFNameAddress ca șir
Dim xStr As String
xArrShetts = Array("02302257", "02400438", "02401829", "02403995", "02408001", "02409208", _
„02409980”, „02411881”, „02424178”, „02430454”, „02444046”, „02448950”, „02450600”, _
„02459861”, „02461750”, „02467535”, „02480484”, „02484749”, „02502041”, „02504807”, _
„02511843”, „02515193”, „02523098”, „02523244”, „02524036”, „02524548”, „02525516”, „02525703”, „02525898”, „02528908”, „02528950”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”,
„02530381”, „02531018”, „02531252”, „02531277”, „02532571”, „02533053”, „02533474”, _
„02534176”, „02534592”, „02534626”, „02535343”, „02536386”, „02536921”, „02537544”, _
„02537607”, „02538015”, „02538755”, „02538836”, „02538910”, „02539685”, „02540063”, „02540139”, „02540158”, „02541607”, „02542344”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”,
„02543763”, „02543985”, „02544116”, „02544748”, „02544762”, „02545026”, „02545048”, _
„02545080”, „02545447”, „02545730”, „02545814”, „02546477”, „02547458”, „02547673”, _
„02547833”, „02547912”, „02547950”, „02547991”, „02548848”, „02549103”, „02549116”, „02549125”, „02549132”, „02549140”, „02549182”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”,
„02549462”, „02549499”, „02549565”, „02549687”, „02550049”, „02550437”, „02550812”, _
„02550982”, „02551004”, „02551005”, „02551045”, „02552099”, „02552222”, „02552561”, _
„02552684”, „02552815”, „02552892”, „02553031”, „02553186”, „02553628”, „02553721”, „02555186”, „02556934”, „02557137”, „02557393”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”,
„02559121”, „02559392”, „02559419”, „02559512”, „02559802”, „02559868”, „02560052”, _
„02560612”, „02560684”, „02560920”, „02561018”, „02561061”, „02561092”, „02561227”, _
„02561349”, „02561592”, „02561630”, „02561673”, „02561880”, „02562359”, „02562920”, „02562934”, „02563013”, „02563119”, „02563133”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”, „XNUMX”,
„02563445”, „02563737”, „02563828”, „02563852”, „02563861”, „02563971”, „02564042”, _
„02564315”, „02564366”, „02564832”, „02564909”, „02565059”, „02565205”) „Introduceți numele foilor pe care le veți trimite ca fișiere pdf închise cu ghilimele și separați-le cu virgulă. Asigurați-vă că nu există caractere speciale, cum ar fi \/:"*<>| în numele fișierului.

Pentru I = 0 La UBound(xArrShetts)
La data de eroare CV următoare
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
Dacă xSht.Name <> xArrShetts(I) Atunci
MsgBox „Foaia de lucru nu a fost găsită, operațiune de ieșire:” & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, „Kutools pentru Excel”
Ieșiți din Sub
Final, dacă
Pagina Următoare →


Setați xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Dacă xFileDlg.Show = Adevărat, atunci
xFolder = xFileDlg.SelectedItems(1)
Altfel
MsgBox „Trebuie să specificați un folder în care să salvați PDF-ul”. & vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Trebuie să specificați folderul de destinație”
Ieșiți din Sub
Final, dacă
„Verificați dacă fișierul există deja
xYesorNo = MsgBox(„Dacă fișierele cu același nume există în folderul de destinație, sufixul numeric va fi adăugat automat la numele fișierului pentru a distinge duplicatele” & vbCrLf & vbCrLf & „Faceți clic pe Da pentru a continua, faceți clic pe Nu pentru a anula”, _
vbYesNo + vbÎntrebare, „Fișierul există”)
Dacă xDasauNu <> vbDa, atunci Ieșiți din sub
Pentru I = 0 La UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))

xStr = xFolder & „\” & xSht.Name & „.pdf”
xNum = 1
În timp ce nu (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Merge încet
Setați xUsedRng = xSht.UsedRange
Dacă Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Atunci
xSht.ExportAsFixedFormat Type:=xlTypePDF, Nume fișier:=xStr, Quality:=xlQualityStandard
Altfel

Final, dacă
xArrShetts(I) = xStr
Pagina Următoare →

„Creează e-mail Outlook
Setați xOutlookObj = CreateObject("Outlook.Application")
Setați xEmailObj = xOutlookObj.CreateItem(0)
Cu xEmailObj
.Afişa
.To = „Ctracklegal@ctrack.com”
.CC = ""
.Subiect = "????"
Pentru I = 0 La UBound(xArrShetts)
La data de eroare CV următoare
.Atașamente.Adăugați xArrShetts(I)
Pagina Următoare →
Dacă DisplayEmail = False, atunci
.Trimite
Ieșiți din Sub
Final, dacă
Se termina cu


End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună @crystal
Acesta este fabulos - lucrul cheie cu care mă confrunt este numele fișierului - aș dori ca numele fișierului să fie extras dintr-o celulă din foaia de lucru, mai degrabă decât să folosesc numele filei. Am editat deja codul pentru a-l salva automat într-un folder specificat, dar mă confrunt cu numele fișierului.
Va rog ceva ajutor pe care il puteti oferi?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună Tori, Dacă doriți să denumiți fișierul PDF cu o anumită valoare a celulei, vă rugăm să încercați următorul cod. După ce rulați codul și selectați un folder pentru a salva fișierul, va apărea o altă casetă de dialog, vă rugăm să selectați celula pe care o veți folosi valoarea ca nume al fișierului PDF, apoi faceți clic pe OK pentru a finaliza.
Sub Saveaspdfandsend2()
„Actualizat de Extendoffice 20210521
Dim xSht ca foaie de lucru
Dim xFileDlg ca FileDialog
Dim xFolder ca șir
Dim xYesorNo ca întreg
Dim xOutlookObj ca obiect
Dim xEmailObj ca obiect
Dim xUsedRng, xRgInser As Range
Dim xB ca boolean
Setați xSht = ActiveSheet
Setați xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

Dacă xFileDlg.Show = Adevărat, atunci
xFolder = xFileDlg.SelectedItems(1)
Altfel
MsgBox „Trebuie să specificați un folder în care să salvați PDF-ul”. & vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Trebuie să specificați folderul de destinație”
Ieșiți din Sub
Final, dacă
xB = Adevărat
La data de eroare CV următoare
În timp ce xB
Set xRgInser = Nimic
Set xRgInser = Application.InputBox ("Selectați o celulă pe care o veți folosi valoarea pentru a denumi fișierul PDF:", "Kutools for Excel", , , , , , 8)
Dacă xRgInser este nimic, atunci
MsgBox „ Nicio celulă selectată, ieșiți din operație!”, vbInformation, „Kutools pentru Excel”
Ieșiți din Sub
Final, dacă
Dacă xRgInser.Text = "" Atunci
MsgBox „ Celula selectată este goală, vă rugăm să reselegeți!”, vbInformation, „Kutools pentru Excel”
Altfel
xB = Fals
Final, dacă
Merge încet

xFolder = xFolder + „\” + xRgInser.Text + „.pdf”

„Verificați dacă fișierul există deja
Dacă Len(Dir(xFolder)) > 0, atunci
xYesorNo = MsgBox(xFolder & „există deja.” & vbCrLf & vbCrLf & „Doriți să-l suprascrieți?”, _
vbYesNo + vbÎntrebare, „Fișierul există”)
La data de eroare CV următoare
Dacă xDa sauNu = vbDa Atunci
Omorâți xFolder
Altfel
MsgBox „dacă nu suprascrii PDF-ul existent, nu pot continua.” _
& vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Ieșire din macrocomandă”
Ieșiți din Sub
Final, dacă
Dacă Err.Number <> 0 Atunci
MsgBox „Nu se poate șterge fișierul existent. Asigurați-vă că fișierul nu este deschis sau protejat la scriere.” _
& vbCrLf & vbCrLf & „Apăsați pe OK pentru a ieși din această macrocomandă.”, vbCritical, „Nu se poate șterge fișierul”
Ieșiți din Sub
Final, dacă
Final, dacă

Setați xUsedRng = xSht.UsedRange
Dacă Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Atunci
„Salvați ca fișier PDF
xSht.ExportAsFixedFormat Tip:=xlTypePDF, Nume fișier:=xFolder, Quality:=xlQualityStandard

„Creează e-mail Outlook
Setați xOutlookObj = CreateObject("Outlook.Application")
Setați xEmailObj = xOutlookObj.CreateItem(0)
Cu xEmailObj
.Afişa
.To = ""
.CC = ""
.Subiect = xSht.Name + „.pdf”
.Atașamente.Adăugați xFolder
Dacă DisplayEmail = False, atunci
'.Trimite
Final, dacă
Se termina cu
Altfel
MsgBox „Foaia de lucru activă nu poate fi goală”
Ieșiți din Sub
Final, dacă
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună, aveam nevoie de ceva similar, așa că iată ce am primit. Ia data curentă și creează un nou folder cu numele datei într-o anumită locație. Plasează pdf-ul în acea nouă locație, apoi atașează pdf-ul într-un e-mail nou. Funcționează ca un răsfăț. Sunt doar un începător, așa că vă rog să mă scuzați dacă pare o mizerie. :D
Sub PDFTOEMAIL()
Dim xSht ca foaie de lucru
Dim xFileDlg ca FileDialog
Dim xFolder ca șir
Dim xYesorNo ca întreg
Dim xOutlookObj ca obiect
Dim xEmailObj ca obiect
Dim xUsedRng As Range
Dim xPath ca șir
Dim xOutMsg ca șir
Dim sFolderName ca șir, sFolder ca șir
Dim sFolderPath ca șir

Setați xSht = ActiveSheet
xFileDate = Format(Acum, „zz-mm-aaaa”)
sFolder = „C:” „aici este locul în care aveți un folder principal
sFolderName = „Sfârșitul săptămânii” + Format(Acum, „zz-mm-aaaa”) „dosarul de creat în folderul principal cu numele Sfârșitul săptămânii și data curentă
sFolderPath = „C:” și sFolderName „dosarul principal” din nou pentru a crea noua cale, inclusiv noul folder
Set ofFSO = CreateObject("Scripting.FileSystemObject")
Dacă oFSO.FolderExists(sFolderPath) atunci
MsgBox „Folderul există deja!” & vbCrLf & vbCrLf & sFolderPath, vbInformation, „INFO”
Altfel
MkDir sFolderPath
MsgBox „Doar nou a fost creat!” & vbCrLf & vbCrLf & sFolderPath, vbInformation, „INFO”
Final, dacă
xPath = sFolderPath
xFolder = xPath + „\” + xSht.Name + „_” + xFileDate + „.pdf”
Dacă Len(Dir(xFolder)) > 0, atunci
xYesorNo = MsgBox(xFolder & „există deja.” & vbCrLf & vbCrLf & „Doriți să-l suprascrieți?”, _
vbYesNo + vbÎntrebare, „Fișierul există”)
La data de eroare CV următoare
Dacă xDa sauNu = vbDa Atunci
Omorâți xFolder
Altfel
MsgBox „dacă nu suprascrii PDF-ul existent, nu pot continua.” _
& vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Ieșire din macrocomandă”
Ieșiți din Sub
Final, dacă
Dacă Err.Number <> 0 Atunci
MsgBox „Nu se poate șterge fișierul existent. Asigurați-vă că fișierul nu este deschis sau protejat la scriere.” _
& vbCrLf & vbCrLf & „Apăsați pe OK pentru a ieși din această macrocomandă.”, vbCritical, „Nu se poate șterge fișierul”
Ieșiți din Sub
Final, dacă
Final, dacă

Setați xUsedRng = xSht.UsedRange
Dacă Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Atunci
xSht.ExportAsFixedFormat Tip:=xlTypePDF, Nume fișier:=xFolder, Quality:=xlQualityStandard
Setați xOutlookObj = CreateObject("Outlook.Application")
Setați xEmailObj = xOutlookObj.CreateItem(0)
xOutMsg = " Vă rugăm să găsiți atașat Acest e-mail și atașamentul au fost generate automat "
'adaugă o notă că e-mailul a fost generat automat

Cu xEmailObj
.Afişa
.Pentru a = "" 'adăugați propriile e-mailuri
.CC = ""
.Subject = xSht.Name + " PDF pentru sfârșitul săptămânii " + xFileDate + " - Locație " ' subiectul include numele foii, pdf, data și locația, aceasta poate fi editată după cum este necesar
.Atașamente.Adăugați xFolder
.HTMLBody = xOutMsg & .HTMLBody
Dacă DisplayEmail = False, atunci
'.Trimite <--- Aici, dacă ștergeți apostroful, e-mailul va fi trimis automat, așa că vă rugăm să aveți grijă
Final, dacă
Se termina cu
Altfel
MsgBox „Foaia de lucru activă nu poate fi goală”
Ieșiți din Sub
Final, dacă
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Cum editez acest cod pentru a salva numai celule ("a1:r99") pentru a le salva ca PDF. Am lucruri suplimentare pe părțile pe care nu le doresc în documentul meu PDF.
Sub Saveaspdfandsend()
„Actualizat de Extendoffice 20210209
Dim xSht ca foaie de lucru
Dim xFileDlg ca FileDialog
Dim xFolder ca șir
Dim xYesorNo ca întreg
Dim xOutlookObj ca obiect
Dim xEmailObj ca obiect
Dim xUsedRng As Range
Dim xStrName ca șir
Dim xV ca variantă

Setați xSht = ActiveSheet
Setați xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

Dacă xFileDlg.Show = Adevărat, atunci
xFolder = xFileDlg.SelectedItems(1)
Altfel
MsgBox „Trebuie să specificați un folder în care să salvați PDF-ul”. & vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Trebuie să specificați folderul de destinație”
Ieșiți din Sub
Final, dacă
xStrName = ""
xV = Application.InputBox(„Vă rugăm să introduceți numele fișierului:”, „Kutools pentru Excel”, , , , , , 2)
Dacă xV = Fals, atunci
Ieșiți din Sub
Final, dacă
xStrName = xV
Dacă xStrName = "" Atunci
MsgBox ("Nu s-a introdus niciun nume de fișier, se iese din proces!")
Ieșiți din Sub
Final, dacă

xFolder = xFolder + „\” + xStrName + „.pdf”
„Verificați dacă fișierul există deja
Dacă Len(Dir(xFolder)) > 0, atunci
xYesorNo = MsgBox(xFolder & „există deja.” & vbCrLf & vbCrLf & „Doriți să-l suprascrieți?”, _
vbYesNo + vbÎntrebare, „Fișierul există”)
La data de eroare CV următoare
Dacă xDa sauNu = vbDa Atunci
Omorâți xFolder
Altfel
MsgBox „dacă nu suprascrii PDF-ul existent, nu pot continua.” _
& vbCrLf & vbCrLf & „Apăsați OK pentru a ieși din această macrocomandă.”, vbCritical, „Ieșire din macrocomandă”
Ieșiți din Sub
Final, dacă
Dacă Err.Number <> 0 Atunci
MsgBox „Nu se poate șterge fișierul existent. Asigurați-vă că fișierul nu este deschis sau protejat la scriere.” _
& vbCrLf & vbCrLf & „Apăsați pe OK pentru a ieși din această macrocomandă.”, vbCritical, „Nu se poate șterge fișierul”
Ieșiți din Sub
Final, dacă
Final, dacă

Setați xUsedRng = xSht.UsedRange
Dacă Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Atunci
„Salvați ca fișier PDF
xSht.ExportAsFixedFormat Tip:=xlTypePDF, Nume fișier:=xFolder, Quality:=xlQualityStandard

„Creează e-mail Outlook
Setați xOutlookObj = CreateObject("Outlook.Application")
Setați xEmailObj = xOutlookObj.CreateItem(0)
Cu xEmailObj
.Afişa
.To = ""
.CC = ""
.Subiect = xSht.Name + „.pdf”
.Atașamente.Adăugați xFolder
Dacă DisplayEmail = False, atunci
'.Trimite
Final, dacă
Se termina cu
Altfel
MsgBox „Foaia de lucru activă nu poate fi goală”
Ieșiți din Sub
Final, dacă
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună ziua, tocmai am încercat acest cod pe una dintre foile mele de lucru și am zone de tipărire setate, astfel încât lucrurile suplimentare din partea de jos să nu apară în pdf. Incearca-l!
Acest comentariu a fost redus la minimum de moderatorul de pe site
Hi
Mulțumesc pentru cod, dar este posibil să salvați PDF-ul automat în aceeași locație ca fișierul Excel activ și cu același nume de fișier ca fișierul Excel activ?
Multe mulțumiri.
tijă
Nu există comentarii postate aici încă
Încărcați mai
Lăsa comentarii
Postare ca invitat
×
Evaluează această postare:
0   Caractere
Locații sugerate

Urmărește-ne

Copyright © 2009 - www.extendoffice.com. | Toate drepturile rezervate. Cu sprijinul ExtendOffice. | Harta site-ului
Microsoft și sigla Office sunt mărci comerciale sau mărci comerciale înregistrate ale Microsoft Corporation în Statele Unite și / sau în alte țări.
Protejat de Sectigo SSL