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

Question

我目前有一个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

此代码完美地将Excel工作表分解为基于D列的分页符，并将它们作为单独的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

Answer 1

作为您之前帖子的后续内容，此修改后的代码会在＆＃39; pdf＆＃39;中添加hpage break，当＆＃39; group＆＃39;变化。复制整个代码而不是尝试修改现有代码;有一些变化，但太多无法解释。例如，我之前忘记包含Option Explicit，并且必须声明一些变量以防止某些变量未定义＆＃39;错误（啧啧，啧啧）！在我的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