EXCEL VBA - Экспорт листа в PDF и отправка в виде вложения по электронной почте

Question

Я работал над следующим кодом, который создает копию рабочей таблицы, затем очищает ее от ненужных данных, а затем экспортирует использованный диапазон новой рабочей таблицы в PDf и, наконец, создает электронное письмо с этим PDF-файлом в качестве вложения.

Все отлично работает, кроме одной "мелочи".Я не могу "персонализировать" имя файла PDF.Моя цель заключается в том, чтобы автоматически иметь имя файла с именем клиента и другой информацией, полученной из исходного листа.Пожалуйста, будьте так любезны, дайте мне понять, где я ошибаюсь и как я могу решить эту проблему?Естественно, этот код может быть оптимизирован (на самом деле подпрограмма немного медленная), но, возможно, после решения этой проблемы; -)

Вот это код

Sub ExportToPDFAndEmail()
Dim yFileDlg As FileDialog
Dim yFolder As String
Dim yYesorNo As Integer
Dim yOutlookObj As Object
Dim yEmailObj As Object
Dim NomeCliente, Subj, Email As String

Set yFileDlg = Application.FileDialog(msoFileDialogFolderPicker)


'Copies and pastes a copy of TEMPLATE Worksheet, then it cleans the new Sheet up from unsuseful data _
'and blank rows in the description column, finally it deletes some columns
Application.ScreenUpdating = False
    Sheets("TEMPLATE").Select
    Sheets("TEMPLATE").Copy Before:=Sheets(1)
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.Delete
    Range("F9").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeFormulas, 16).Select
    Selection.EntireRow.Delete
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("F:Z").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Range("B2").Select

'User can choose Folder and filename to save PDF
If yFileDlg.Show = True Then
   yFolder = yFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "You must specify destination folder."
   Application.DisplayAlerts = False
   ActiveSheet.Delete
   Application.DisplayAlerts = True
   Exit Sub
End If

PDFname = Worksheets("TEMPLATE").Range("J1").Value
yFolder = yFolder + "\" + "Sollecito al " + ".pdf"

'Checks if file already exists
If Len(Dir(yFolder)) > 0 Then
    yYesorNo = MsgBox(yFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If yYesorNo = vbYes Then
        Kill yFolder
    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 the file"
        Exit Sub
    End If
End If

s = Worksheets("TEMPLATE").Range("X2").Value
NomeCliente = Worksheets("TEMPLATE").Range("B3").Value
Email = Worksheets("TEMPLATE").Range("D4").Value
Subj = Worksheets("TEMPLATE").Range("X2").Value
MesgBefore = Worksheets("TEMPLATE").Range("X3").Value
MesgAfter = Worksheets("TEMPLATE").Range("X6").Value
MesgBefore = Replace(Replace(MesgBefore, "#NomeCliente#", NomeCliente), Chr(10), "<br>")
MesgAfter = Replace(Replace(MesgAfter, "#NomeCliente#", NomeCliente), Chr(10), "<br>")


Set rng = ActiveSheet.UsedRange
ActiveSheet.PageSetup.PrintArea = rng.Address
With ActiveSheet.PageSetup
        .PrintTitleRows = "$2:$8"
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 6
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With

'Exports to PDF
rng.ExportAsFixedFormat Type:=xlTypePDF, fileName:=yFolder, Quality:=xlQualityStandard

'Creates Outlook Email
Set yOutlookObj = CreateObject("Outlook.Application")
Set yEmailObj = yOutlookObj.CreateItem(0)
    With yEmailObj
        .To = Email
        .CC = ""
        On Error Resume Next
        .Attachments.Add yFolder
        On Error GoTo 0
        .Subject = s
        .HTMLBody = .HTMLBody & "<br>" & MesgBefore & "<br><br>" & MesgAfter & "</font></span>"
        .Display
    End With
On Error GoTo 0
Set yEmailObj = Nothing
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Я хотел бы получить имяPDF в качестве значения в J1.

PDFname = Worksheets("TEMPLATE").Range("J1").Value

Но если я добавлю PDFname в yFolder, процедура выдаст ошибку.

Не могли бы вы мне помочь?

Answer 1

Я немного новичок в vba и смотрю на это на своем телефоне, поэтому, пожалуйста, простите меня, если я далеко, но я хотел бы попытаться помочь. Вы должны затемнить свое имя PDF? Я никогда не видел ее как объявленную переменную, однако снова я смотрю на это на своем телефоне, чтобы я мог легко пропустить это