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

Question

我有一个 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 文件中？

Answer 1

将工作表的多个版本导出为 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