Question

为了避免错误并提供良好的用户体验，我已经深入挖掘，最好避免使用.Select，.Activate，ActiveSheet，ActiveCell等等。

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

使用For Each;但是，这导致单独的PDF文件，这是不好的。

使用类似于宏录制器生成的代码，该代码使用.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

讨厌疏通一个老问题，但是我讨厌看到有人在这个问题上磕磕绊绊地诉诸于其他答案中的代码体操。 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 2

它钻进了我的脑海（通过很多......

我知道你是什么MEAN;）

以下是一种不使用.Select/.Activate/ActiveSheet

的方法

逻辑：

删除不必要的工作表
导出整个工作簿。
关闭工作簿而不保存，以便恢复已删除的工作表

<强>代码：

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 3

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

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

不使用ActiveSheet或Select，将多个工作表同时导出为PDF

4 个答案:

WorkingWorkbook.cls

测试程序