主页 / coding / 问题 / 79157206
Accepted
BrandonC
Asked: 2024-11-05 06:49:08 +0800 CST

将单个工作表和范围导出为多页 PDF

  • 772

我编写了一个宏脚本，该脚本会获取 Excel 文件中选定的一组工作表，并将它们全部导出为单个 PDF 文档。但是，有些情况下，这些文档的接收者需要此合并 PDF 中某些页面的多个副本。我想知道我是否可以设置它，以便某些工作表在最终导出的 PDF 中有重复的页面。

例如，假设 sheet1 是最终 PDF 中的一张表。我想找到一种方法，让 sheet1 中的页面被复制多次。

以下是宏的原始代码以及它使用的辅助函数：

Sub ExportToPDF()
Dim wb As Workbook
Set wb = ActiveWorkbook

    Dim mds As Worksheet
    Set mds = wb.Sheets("Master Data Sheet")
    
    Dim DefaultSheets, SelectedSheets As Variant
    DefaultSheets = Array("Proforma Invoice", "SLI", "VGM Form", "Commercial Invoice", "Cert of Origin", "Packing List")
    
    Dim Country, Company, CurrDate, OrderNo, FilePath As String
    Country = mds.Range("E49").Value
    Company = mds.Range("D36").Value
    CurrDate = mds.Range("E46").Value
    OrderNo = mds.Range("E39").Value
    
    For Each Sheet In Array("Master Data Sheet", "Multi Order Queries", "Packing List Query")
        wb.Worksheets(Sheet).Visible = xlSheetHidden
    Next
    
    FilePath = GetFolder()
    
    wb.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        IncludeDocProperties:=True, _
        Filename:=FilePath + "\" + Company + "_" + OrderNo + "_" + CurrDate + ".pdf", _
        OpenAfterPublish:=True
        
    For Each Sheet In Array("Master Data Sheet", "Multi Order Queries", "Packing List Query")
        wb.Worksheets(Sheet).Visible = xlSheetVisible
    Next
    
    mds.Activate

帮手：

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function
excel

1 个回答

  1. Best Answer

    这对我有用 - 创建所需数量的工作表副本，导出，然后删除副本。

    请注意，如果您只导出选定的工作表，则无需隐藏其他工作表。

    Sub ExportToPDF()
    
    Const WSTOCOPY As String = "SLI" 'for example: the sheet to be copied
    
    Dim wb As Workbook, mds As Worksheet, wsName, first As Boolean
    Dim DefaultSheets, SelectedSheets As Variant, NumCopies As Long, i As Long
    Dim Country As String, Company As String, CurrDate As String
    Dim OrderNo As String, FilePath As String, wsCopy As Worksheet
    
    Set wb = ActiveWorkbook

    Set mds = wb.Sheets("Master Data Sheet")
    
    DefaultSheets = Array("Proforma Invoice", "SLI", "VGM Form", _
                          "Commercial Invoice", "Cert of Origin", _
                          "Packing List")
    
    Country = mds.Range("E49").Value
    Company = mds.Range("D36").Value
    CurrDate = mds.Range("E46").Value
    OrderNo = mds.Range("E39").Value
    
    NumCopies = mds.Range("B5").Value 'for example
    
    Set wsCopy = wb.Worksheets(WSTOCOPY)
    CreateCopies wsCopy, NumCopies 'create any required copies
    
    first = True
    For Each wsName In DefaultSheets
        ThisWorkbook.Worksheets(wsName).Select first 'if true then replaces current selection
        first = False                                '   otherwise adds the sheet to the current selection
        If wsName = wsCopy.Name Then
            For i = 1 To NumCopies - 1 'select all the copies of the sheet
                wb.Worksheets(wsCopy.Index + i).Select first
            Next i
        End If
    Next wsName
    
    FilePath = GetFolder()
    
    'export only selected sheets
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, IncludeDocProperties:=True, _
        Filename:=FilePath + "\" + Company + "_" + OrderNo + "_" + CurrDate + ".pdf", _
        OpenAfterPublish:=True
        
    RemoveCopies wb 'remove any copies
    
    mds.Select
    
End Sub

'Create copies of worksheet `wsRep`
Sub CreateCopies(wsRep As Worksheet, totalCopies As Long)
    Dim i As Long, ws As Worksheet
    Set ws = wsRep
    For i = 1 To totalCopies - 1
        wsRep.Copy after:=ws
        Set ws = ws.Next
        ws.Name = wsRep.Name & "_COPY" & (i + 1)
    Next i
End Sub

'remove all worksheets in `wb` where name contains "_COPY"
Sub RemoveCopies(wb As Workbook)
    Dim i As Long
    Application.DisplayAlerts = False
    For i = wb.Worksheets.Count To 1 Step -1
        With wb.Worksheets(i)
            If UCase(.Name) Like "*_COPY*" Then .Delete
        End With
    Next i
    Application.DisplayAlerts = True
End Sub
    • 0

相关问题