时间戳

首页 > 解决方案 > 范围导出创建 50 个单独的 PDF - 如何组合

excel - 范围导出创建 50 个单独的 PDF - 如何组合

问题描述

我有一个 excel 仪表板文档，其中单元格 D1 有一个包含 50 个代表名称的下拉列表。当 D1 改变时，页面上的所有数据都会改变。我的代码为 D1 中的每个值导出一个单独的 PDF，并将其加载到我们驱动器上代表的个人文件中。我还想将所有 50 个 PDF 合并到一个 PDF 文件中，供我们的管理团队查看并将其保存在单独的文件夹中。我的代码目前如下所示：

Sub MakeFiles()

Dim rep As String
Dim reppath As String
Dim path As String
Dim pathmanagement As String
Dim MyFileName As String
Dim myrange As Range
Dim i As Range
On Error GoTo errHandler


ActiveWorkbook.Sheets("REF").Visible = False
ActiveWorkbook.Sheets("Individual").Activate

path = "C:\Users\ph\vf\Reporting\"
pathmanagement = "C:\Users\ph\vf\Reporting\management"

Set myrange = Worksheets("REF").Range("A2", Worksheets("REF").Range("a2").End(xlDown))


For Each i In myrange


Worksheets("Individual").Range("d1").Value = i
Application.Calculate
rep = Worksheets("Individual").Range("d1").Value

ActiveWorkbook.Sheets("Individual").Activate


ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=path & ActiveSheet.Range("f1").Value & "\" & ActiveSheet.Range("g1").Value & "\" & "Territory Summary" & " " & ActiveSheet.Range("e1").Value & " " & Format(DateAdd("m", -1, Date), "mmmm yyyy") & ".pdf"

ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pathmanagement & "\" & "Rep Territory Summaries" & "\" & "Territory Summary" & " " & ActiveSheet.Range("e1").Value & ".pdf"

Next i

MsgBox "Done!"

Exit Sub

errHandler: MsgBox "Could not create PDF file."

End Sub

有什么我可以添加到此代码中以获得单个 PDF 来显示 D1 中所有 50 个值的结果吗？或者，如果我将每个文件的副本上传到单独的文件夹中，是否有代码可以自动将它们合并到一个 PDF 文件中？

标签： excelvbapdf

解决方案

将工作表的多个版本导出为 PDF

  • 未测试。
  • 以下应该循环遍历列A并Source写入每个值，由于公式重新计算D1，Destination该列将生成不同版本的。Destination然后这个版本将被导出PDF到两个路径（最初），它将被复制到一个新添加的工作簿（添加）。最后，新工作簿将导出PDF并关闭而不保存更改。
  • 适当调整AnotherFilePath。
Option Explicit

Sub MakeFiles()

    Const RepPath As String = "C:\Users\ph\vf\Reporting\"
    Const ManPath As String = "C:\Users\ph\vf\Reporting\management\"
    
    On Error GoTo errHandler
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
        
    Dim dws As Worksheet: Set dws = wb.Worksheets("Individual")
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("REF")
    sws.Visible = False
    ' The following line assumes that the data doesn't contain any empty
    ' cells. Using `xlUp` is the preferred (usually safer) way.
    Dim srg As Range: Set srg = sws.Range("A2", sws.Range("A2").End(xlDown))
    
    Dim rwb As Workbook
    Dim sCell As Range
    Dim n As Long
    
    For Each sCell In srg.Cells
        
        dws.Range("D1").Value = sCell.Value
        Application.Calculate
        
        wb.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=RepPath & dws.Range("F1").Value & "\" _
            & dws.Range("G1").Value & "\" & "Territory Summary" _
            & " " & dws.Range("E1").Value & " " _
            & Format(DateAdd("m", -1, Date), "mmmm yyyy") & ".pdf"
        
        wb.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=ManPath & "Rep Territory Summaries" & "\" _
            & "Territory Summary" & " " & dws.Range("e1").Value & ".pdf"
    
        n = n + 1
        If n = 1 Then
            dws.Copy ' adds a new workbook containing only the current 'dws'
            Set rwb = ActiveWorkbook
        Else
            dws.Copy After:=rwb.Sheets(rwb.Sheets.Count)
        End If
        ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
    
    Next sCell
    
    rwb.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:="AnotherFilePath" & ".pdf"
    rwb.Close False
    
    MsgBox "Exported " & n & " worksheets.", vbInformation, "PDF Export"
    
ProcExit:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file."
    Resume ProcExit
End Sub

推荐阅读