范围导出创建 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，该 PDF 将显示 D1 中所有 50 个值的结果？或者，如果我将每个文件的副本上传到单独的文件夹中，是否有代码会自动将它们合并到一个 PDF 文件中？

Answer 1

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

• 未测试。
• 以下内容应遍历A 的Source 列并将每个值写入Destination 的D1，由于公式重新计算，这将生成不同版本的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