一键将多张纸保存到一个位置

Question

该宏遍历工作簿中的每个工作表，询问将每个工作表另存为PDF的位置，然后打开带有PDF附件的Outlook电子邮件（一对一），准备发送给最终用户。

我想选择一个位置来保存所有PDF，而不会出现提示窗口，问我在哪里保存每个工作表。

Option Explicit

Sub WorksheetLoop()
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
Sheets(I).Select

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

EmailSubject = "Bid Awarded to " & Range("D3") & " on " & Range("D2")
OpenPDFAfterCreating = False
AlwaysOverwritePDF = False
DisplayEmail = True
Email_To = Range("D4")
Email_CC = "Email@Email.com"
Email_BCC = ""


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

CurrentMonth = Mid(ActiveSheet.Range("H6").Value, InStr(1, ActiveSheet.Range("H6").Value, " ") + 1)

PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
            & "_" & CurrentMonth & ".pdf"


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

Sheets(Array(ActiveWorkbook.Worksheets(I).Name)).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
    :=False, OpenAfterPublish:=OpenPDFAfterCreating


Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)

With OutlookMail

    .Display
    .To = Email_To
    .CC = Email_CC
    .BCC = Email_BCC
    .Subject = EmailSubject & CurrentMonth
    .Attachments.Add PDFFile

    If DisplayEmail = False Then

        .Send
        MsgBox ActiveWorkbook.Worksheets(I).Name

    End If

End With

Next I


End Sub

现在，它将为每个工作表打开一封电子邮件，但每次都询问在何处保存新创建的PDF。我希望它将所有工作表保存到一个指定的位置。

Answer 1

您需要移动此位...

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

在循环语句上方

您的代码应如下所示...

Option Explicit

Sub WorksheetLoop()
Dim WS_Count As Integer
Dim I As Integer
Dim DestFolder as String   ' Moved this above your Loop statement

WS_Count = ActiveWorkbook.Worksheets.Count

With Application.FileDialog(msoFileDialogFolderPicker)  'Move the folder selection code above your loop statement

    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

For I = 1 To WS_Count
Sheets(I).Select

Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth 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 = ""

EmailSubject = "Bid Awarded to " & Range("D3") & " on " & Range("D2")
OpenPDFAfterCreating = False
AlwaysOverwritePDF = False
DisplayEmail = True
Email_To = Range("D4")
Email_CC = "anthony@narid.com"
Email_BCC = ""

CurrentMonth = Mid(ActiveSheet.Range("H6").Value, InStr(1, ActiveSheet.Range("H6").Value, " ") + 1)

PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
            & "_" & CurrentMonth & ".pdf"


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

Sheets(Array(ActiveWorkbook.Worksheets(I).Name)).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
    :=False, OpenAfterPublish:=OpenPDFAfterCreating


Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)

With OutlookMail

    .Display
    .To = Email_To
    .CC = Email_CC
    .BCC = Email_BCC
    .Subject = EmailSubject & CurrentMonth
    .Attachments.Add PDFFile

    If DisplayEmail = False Then

        .Send
        MsgBox ActiveWorkbook.Worksheets(I).Name

    End If

End With

Next I


End Sub