Excel VBA 通过在多个 PDF 中分组来创建分页符答案

【问题标题】：Excel VBA to Create Page Breaks by Grouping Within Multiple PDFsExcel VBA 通过在多个 PDF 中分组来创建分页符
【发布时间】：2014-11-12 19:45:50
【问题描述】：

我目前有一个Excel sheet，它有四列：名字 (A)、姓氏 (B)、组 (C) 和 PDF (D)。感谢another thread 的帮助，我们能够保护以下 VBA 代码，该代码可以根据 D 列将电子表格完美拆分为多个 PDF：

Option Base 1
Sub pdf()
Dim ws As Worksheet
Dim dArr() As String, outputPath As String, fileStem As String
Dim dCol As Long, stRow As Long, endRow As Long, pStRow As Long
Dim docCnt As Long, lnCnt As Long
Dim rwsPerPage As Integer, topM As Integer, botM As Integer
Dim empNme As String

Set ws = Sheets("Data")
dCol = 4    'col D
stRow = 2   'row 2

pStRow = stRow
rwsPerPage = 50
topM = 36   'default in points
botM = 36   'default in points
outputPath = "<yourpath>\"
fileStem = "Employee "

docCnt = 1
lnCnt = 0

    With ws
        'set essential page parameters
        With .PageSetup
            .Orientation = xlPortrait
            .TopMargin = topM
            .BottomMargin = botM
        End With
        .ResetAllPageBreaks

        'last data row
        endRow = .Cells(Rows.Count, dCol).End(xlUp).Row
        'first employee name
        empNme = .Cells(stRow, dCol)

            'for each data row
            For c = stRow To endRow
                lnCnt = lnCnt + 1

                    'at change of employee name
                    If Not .Cells(c, dCol).Value = empNme Then
                        'put doc range into array
                        ReDim Preserve dArr(docCnt)
                        dArr(docCnt) = .Range(.Cells(pStRow, dCol - 3), .Cells(c - 1, dCol - 1)).Address
                        docCnt = docCnt + 1
                        'reset startrow of new employee
                        pStRow = c
                        empNme = .Cells(c, dCol).Value
                        'add hpage break
                        .HPageBreaks.Add before:=.Cells(c, dCol)
                        lnCnt = 0
                    End If

                    'at page length
                    If lnCnt = rwsPerPage Then
                        'add hpage break
                        .HPageBreaks.Add before:=.Cells(lnCnt, dCol)
                        lnCnt = 0
                    End If
            Next c

            'last employee if appropriate to array
            If c - 1 > pStRow Then
                ReDim Preserve dArr(docCnt)
                dArr(docCnt) = .Range(.Cells(pStRow, dCol - 3), .Cells(c - 1, dCol - 1)).Address
            End If

            'produce pdf files
            For d = 1 To UBound(dArr, 1)
                .Range(dArr(d)).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    outputPath & fileStem & d & ".pdf", Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                    OpenAfterPublish:=True
            Next d

    End With

End Sub

此代码可以完美地根据 D 列将 Excel 工作表拆分为分页符，并将它们作为单独的 PDF 输出到正确的输出 - 只缺少一个。 C列（组）与D列非常相似，但是虽然我不希望每个组都有个性化的PDF，但我希望每个个性化的PDF（来自D列）按C列分页。例如，对于“员工 1”PDF，而不是在一个 PDF 上包含 13 个姓名（代码当前是如何编写的），它将是一页五个姓名（A 组），然后是第二页八个姓名（B 组）相同的“员工 1”PDF。

任何人都可以帮忙调整代码以使其成为可能吗？

谢谢！

编辑：更新代码：

Option Explicit
Option Base 1
Sub pdf()
Dim ws As Worksheet
Dim dArr() As String, outputPath As String, fileStem As String
Dim dCol As Long, stRow As Long, endRow As Long, pStRow As Long
Dim docCnt As Long, lnCnt As Long, c As Long, d As Long, gCol As Long
Dim rwsPerPage As Integer, topM As Integer, botM As Integer
Dim empNme As String, empGrp As String
Dim rngRange As Range
Dim i As Long

Set ws = Sheets("Sheet1")
dCol = 8    'col (pdf)
gCol = 7  'col (group)
stRow = 2   'row 2

pStRow = stRow
rwsPerPage = 21
topM = 36   'default in points
botM = 36   'default in points
outputPath = "Macintosh HD:Users:Ryan:Desktop:"
Set rngRange = Worksheets("Sheet1").Range("A2")
fileStem = rngRange.Value

docCnt = 1
lnCnt = 0

For i = 1 To Worksheets.Count
    Sheets(i).PageSetup.PrintTitleRows = "$1:$1"
Next i

    With ws
        'set essential page parameters
        With .PageSetup
            .Orientation = xlLandscape
            .TopMargin = topM
            .BottomMargin = botM
        End With
        .ResetAllPageBreaks

        'last data row
        endRow = .Cells(Rows.Count, dCol).End(xlUp).Row
        'first employee pdf
        empNme = .Cells(stRow, dCol)

        'first group
        empGrp = .Cells(stRow, gCol).Value

            'for each data row
            For c = stRow To endRow
                lnCnt = lnCnt + 1
                    'at change of employee pdf (col dCol)
                    If Not .Cells(c, dCol).Value = empNme Then
                        'put doc range into array
                        ReDim Preserve dArr(docCnt)
                        dArr(docCnt) = .Range(.Cells(pStRow, dCol - gCol), .Cells(c - 1, dCol - 1)).Address
                        docCnt = docCnt + 1
                        'reset startrow of new employee
                        pStRow = c
                        'reset empNme/empGrp
                        empNme = .Cells(c, dCol).Value
                        empGrp = .Cells(c, gCol)
                        'add hpage break
                        .HPageBreaks.Add before:=.Cells(c, dCol)
                        lnCnt = 0
                    Else
                        'at change of group (col gCol)
                        If Not .Cells(c, gCol).Value = empGrp Then
                            'reset empGrp
                            empGrp = .Cells(c, gCol)
                            'add hpage break (within pdf)
                            .HPageBreaks.Add before:=.Cells(c, gCol)
                            lnCnt = 0
                        End If
                    End If

                    'at page length
                    If lnCnt = rwsPerPage Then
                        'add hpage break
                        .HPageBreaks.Add before:=.Cells(lnCnt, dCol)
                        lnCnt = 0
                    End If
            Next c

            'last employee if appropriate to array
            If c - 1 > pStRow Then
                ReDim Preserve dArr(docCnt)
                dArr(docCnt) = .Range(.Cells(pStRow, dCol - gCol), .Cells(c - 1, dCol - 1)).Address
            End If

            'produce pdf files
            For d = 1 To UBound(dArr, 1)
                .Range(dArr(d)).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    outputPath & fileStem & d & ".pdf", Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                    OpenAfterPublish:=True
            Next d

    End With

End Sub

【问题讨论】：

标签： vba excel pdf

【解决方案1】：

作为您上一个帖子的后续内容，此修改后的代码在“组”更改时在“pdf”内添加了一个分页符。复制整个代码而不是尝试修改现有代码；有一些变化，但太多无法解释。例如，我之前忘记包含 Option Explicit 并且必须声明几个变量以防止出现一些“变量未定义”错误（啧啧啧）！在我的 MacBook 上运行良好。

Option Explicit
Option Base 1
Sub pdf()
Dim ws As Worksheet
Dim dArr() As String, outputPath As String, fileStem As String
Dim dCol As Long, stRow As Long, endRow As Long, pStRow As Long
Dim docCnt As Long, lnCnt As Long, c As Long, d As Long, gCol As Long
Dim rwsPerPage As Integer, topM As Integer, botM As Integer
Dim empNme As String, empGrp As String

Set ws = Sheets("Data")
dCol = 4    'col D  (pdf)
gCol = 3    'col C  (group)
stRow = 2   'row 2

pStRow = stRow
rwsPerPage = 50
topM = 36   'default in points
botM = 36   'default in points
outputPath = "untitled:users:<myname>:Desktop:"
fileStem = "Employee "

docCnt = 1
lnCnt = 0

    With ws
        'set essential page parameters
        With .PageSetup
            .Orientation = xlPortrait
            .TopMargin = topM
            .BottomMargin = botM
        End With
        .ResetAllPageBreaks

        'last data row
        endRow = .Cells(Rows.Count, dCol).End(xlUp).Row
        'first employee pdf
        empNme = .Cells(stRow, dCol)

        'first group
        empGrp = .Cells(stRow, gCol).Value

            'for each data row
            For c = stRow To endRow
                lnCnt = lnCnt + 1
                    'at change of employee pdf (col dCol)
                    If Not .Cells(c, dCol).Value = empNme Then
                        'put doc range into array
                        ReDim Preserve dArr(docCnt)
                        dArr(docCnt) = .Range(.Cells(pStRow, dCol - 3), .Cells(c - 1, dCol - 1)).Address
                        docCnt = docCnt + 1
                        'reset startrow of new employee
                        pStRow = c
                        'reset empNme/empGrp
                        empNme = .Cells(c, dCol).Value
                        empGrp = .Cells(c, gCol)
                        'add hpage break
                        .HPageBreaks.Add before:=.Cells(c, dCol)
                        lnCnt = 0
                    Else
                        'at change of group (col gCol)
                        If Not .Cells(c, gCol).Value = empGrp Then
                            'reset empGrp
                            empGrp = .Cells(c, gCol)
                            'add hpage break (within pdf)
                            .HPageBreaks.Add before:=.Cells(c, gCol)
                            lnCnt = 0
                        End If
                    End If

                    'at page length
                    If lnCnt = rwsPerPage Then
                        'add hpage break
                        .HPageBreaks.Add before:=.Cells(lnCnt, dCol)
                        lnCnt = 0
                    End If
            Next c

            'last employee if appropriate to array
            If c - 1 > pStRow Then
                ReDim Preserve dArr(docCnt)
                dArr(docCnt) = .Range(.Cells(pStRow, dCol - 3), .Cells(c - 1, dCol - 1)).Address
            End If

            'produce pdf files
            For d = 1 To UBound(dArr, 1)
                .Range(dArr(d)).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    outputPath & fileStem & d & ".pdf", Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                    OpenAfterPublish:=True
            Next d

    End With

End Sub

【讨论】：

非常感谢！我更新了您的代码并将其粘贴在问题上方以适合我的更大文件。它几乎可以完美运行，只有两件事我无法弄清楚：（1）如何使用范围为第一个 PDF 命名每个 PDF，例如 A2 和 H2，然后如果第二个 PDF 从第 32 行开始，那么它会是 A32 和 H32 等？（如您所见，我在上面尝试过，但它并没有完全做到。）而且（2）我似乎无法控制垂直分页符——你能告诉我如何操作这些?再次感谢！
是时候弄脏你的手了 Ryan？您有一些工作代码要测试/撤消。答案的基础在代码中。 (1) 查找“.Address”并使用此变量修改变量“fileStem”或将其包含在最后一个“For d = ....”循环中并修改“文件名：=”参数。 (2) 你应该有足够的信息从使用 '.HPageBreaks' 转移到 'VPageBreaks。最后，从您之前的编辑中，您可以通过修改“.Orientation”参数将两个（四个字母）变量和格式更改为横向来更改 PDF 和 GROUP 列。祝你好运。
谢谢——我一直在努力！我意识到我可以使用像With ws .VPageBreaks.Add .Range("H1") End With 这样简单的东西来添加水平分页符——但只有添加分页符，它并不能消除我不想要的分页符。我也尝试在最后添加 Set ActiveSheet.VPageBreaks(1).Location = Range("J1") 之类的内容，但我收到了 400 错误。
此参考说明如何删除分页符msdn.microsoft.com/en-us/library/office/…