在不使用 ActiveSheet 或 Select 的情况下同时将多张工作表导出为 PDF

Question

已经钻到我的脑海里了，为了避免bug并提供良好的用户体验，最好避免使用.Select、.Activate、ActiveSheet、ActiveCell等。

记住这一点，有没有一种方法可以在工作簿中的 Sheets 的子集上使用 .ExportAsFixedFormat 方法而不使用上述方法之一？到目前为止，我能想到的唯一方法是：

1. 使用For Each；但是，这会导致生成单独的 PDF 文件，这是不好的。

2. 使用类似于宏记录器生成的代码，使用.Select和ActiveSheet：

   Sheets(Array("Sheet1", "Chart1", "Sheet2", "Chart2")).Select
   ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
       "exported file.pdf", Quality:=xlQualityStandard, _
       IncludeDocProperties:=True, IgnorePrintAreas:=False, openafterpublish:= True
   

也许不使用ActiveSheet 是不可能的，但我至少可以通过某种方式使用.Select 吗？

我试过这个：

Sheets(Array("Sheet1", "Chart1", "Sheet2","Chart2")).ExportAsFixedFormatType:= _
    xlTypePDF, Filename:= "exported file.pdf", Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, openafterpublish:= _
    True

这会产生：

错误 438：对象不支持此属性或方法

Answer 1

它已经深入我的脑海（通过很多......

我知道你是什么MEAN ;)

这是不使用.Select/.Activate/ActiveSheet的一种方式

逻辑：

1. 删除不需要的工作表
2. 导出整个工作簿。
3. 关闭工作簿而不保存，以便找回已删除的工作表

代码：

Sub Sample()
    Dim ws As Object

    On Error GoTo Whoa '<~~ Required as we will work with events

    '~~> Required so that deleted sheets/charts don't give you Ref# errors
    Application.Calculation = xlCalculationManual

    For Each ws In ThisWorkbook.Sheets
        Select Case ws.Name
        Case "Sheet1", "Chart1", "Sheet2", "Chart2"
        Case Else
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End Select
    Next ws

    '~~> Use ThisWorkbook instead of ActiveSheet
    ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    "exported file.pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, openafterpublish:=True

LetsContinue:
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True

    '~~> VERY IMPORTANT! This ensures that you get your deleted sheets back.
    ThisWorkbook.Close SaveChanges:=False

    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

Answer 2

编辑：很高兴地报告说，现在接受的答案使这个想法完全没有必要。

感谢 Siddharth Rout 为我提供了实现这一点的方法！

编辑：如下所述，这个模块大部分都有效，但不完全；我遇到的问题是图表在它们引用的工作表被删除后不保留它们的数据（尽管包含pApp.Calculation = xlCalculationManual 命令）。我一直无法弄清楚如何解决这个问题。当我这样做时会更新。

下面是一个类模块（实现this answer的方法）来解决这个问题。希望它对某人有用，或者如果它对他们不起作用，人们可以提供反馈。

WorkingWorkbook.cls

'**********WorkingWorkbook Class*********'
'Written By: Rick Teachey                '
'Creates a "working copy" of the desired '
'workbook to be used for any number of   '
'disparate tasks. The working copy is    '
'destroyed once the class object goes out'
'of scope. The original workbook is not  '
'affected in any way whatsoever (well, I '
'hope, anyway!)                          '
''''''''''''''''''''''''''''''''''''''''''
Option Explicit

Private pApp As Excel.Application
Private pWorkBook As Workbook
Private pFullName As String

Property Get Book() As Workbook
    Set Book = pWorkBook
End Property

Public Sub Init(CurrentWorkbook As Workbook)
    Application.DisplayAlerts = False

    Dim NewName As String
    NewName = CurrentWorkbook.FullName

    'Append _1 onto the file name for the new (temporary) file
    Do
        NewName = Mid(NewName, 1, InStr(Len(NewName) - 4, NewName, ".") - 1) _
        & Replace(NewName, ".", "_1.", Len(NewName) - 4, 1)
    'Check if the file already exists; if so, append _1 again
    Loop While (Len(Dir(NewName)) <> 0)

    'Save the working copy file
    CurrentWorkbook.SaveCopyAs NewName
    'Open the working copy file in the background
    pApp.Workbooks.Open NewName
    'Set class members
    Set pWorkBook = pApp.Workbooks(Dir(NewName))
    pFullName = pWorkBook.FullName

    Application.DisplayAlerts = True
End Sub

Private Sub Class_Initialize()
    'Do all the work in the background
    Set pApp = New Excel.Application
    'This is the default anyway so probably unnecessary
    pApp.Visible = False
    'Could probably do without this? Well just in case...
    pApp.DisplayAlerts = False
    'Workaround to prevent the manual calculation line from causing an error
    pApp.Workbooks.Add
    'Prevent anything in the working copy from being recalculated when opened
    pApp.Calculation = xlCalculationManual
    'Also probably unncessary, but just in case
    pApp.CalculateBeforeSave = False
    'Two more unnecessary steps, but it makes me feel good
    Set pWorkBook = Nothing
    pFullName = ""
End Sub

Private Sub Class_Terminate()
    'Close the working copy (if it is still open)
    If Not pWorkBook Is Nothing Then
        On Error Resume Next
        pWorkBook.Close savechanges:=False
        On Error GoTo 0
        Set pWorkBook = Nothing
    End If
    'Destroy the working copy on the disk (if it is there)
    If Len(Dir(pFullName)) <> 0 Then
        Kill pFullName
    End If
    'Quit the background Excel process and tidy up (if needed)
    If Not pApp Is Nothing Then
        pApp.Quit
        Set pApp = Nothing
    End If
End Sub

测试程序

Sub test()
    Dim wwb As WorkingWorkbook
    Set wwb = New WorkingWorkbook
    Call wwb.Init(ActiveWorkbook)

    Dim wb As Workbook
    Set wb = wwb.Book
    Debug.Print wb.FullName
End Sub

Answer 3

讨厌挖掘一个老问题，但我不想看到有人在这个问题上磕磕绊绊地求助于其他答案中的代码体操。 ExportAsFixedFormat 方法仅导出可见 工作表和图表。这更清洁、更安全、更容易：

Sub Sample()

    ToggleVisible False

    ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
        "exported file.pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=True

    ToggleVisible True

End Sub

Private Sub ToggleVisible(state As Boolean)
    Dim ws As Object

    For Each ws In ThisWorkbook.Sheets
        Select Case ws.Name
        Case "Sheet1", "Chart1", "Sheet2", "Chart2"
        Case Else
            ws.Visible = state
        End Select
    Next ws
End Sub

Answer 4

一个选项，无需创建新的 WB：

    Option Explicit

Sub fnSheetArrayPrintToPDF()
    Dim strFolderPath As String
    Dim strSheetNamesList As String
    Dim varArray() As Variant
    Dim bytSheet As Byte
    Dim strPDFFileName As String
    Dim strCharSep As String

    strCharSep = ","
    strPDFFileName = "SheetsPrinted"

    strSheetNamesList = ActiveSheet.Range("A1")
    If Trim(strSheetNamesList) = "" Then
        MsgBox "Sheet list is empty. Check it. > ActiveSheet.Range(''A1'')"
        GoTo lblExit
    End If
    For bytSheet = 0 To UBound(Split(strSheetNamesList, strCharSep, , vbTextCompare))
        ReDim Preserve varArray(bytSheet)
        varArray(bytSheet) = Trim(Split(strSheetNamesList, strCharSep, , vbTextCompare)(bytSheet))
    Next

    strFolderPath = Environ("USERPROFILE") & "\Desktop\pdf\"
    On Error Resume Next
    MkDir strFolderPath
    On Error GoTo 0

    If Dir(strFolderPath, vbDirectory) = "" Then
        MsgBox "Err attempting to create the folder: '" & strFolderPath & "'."
        GoTo lblExit
    End If

    Sheets(varArray).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFolderPath & strPDFFileName, _
                                    OpenAfterPublish:=False, IgnorePrintAreas:=False
    MsgBox "Print success." & vbNewLine & " Folder: " & strFolderPath, vbExclamation, "Printing to PDF"

lblExit:
    Exit Sub

End Sub