CODEWITHSUNDEEP
vbaexcelpdf
Ryan
Ryan

Reputation: 531

Excel VBA to Create Page Breaks by Grouping Within Multiple PDFs

I currently have an Excel sheet with four columns: first name (A), last name (B), group (C), and PDF (D). Thanks to the help of another thread, we were able to secure the following VBA code that perfectly splits up the spreadsheet into multiple PDFs based on Column D:

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

This code works perfectly to break up the Excel sheet into page breaks based on Column D and shoot them to the correct output as individual PDFs -- there's just one piece missing. Column C (group) is very similar to Column D, but while I don't want individualized PDFs for each group, I would like each individualized PDF (from Column D) to page break by the group Column C. So for example, for the "Employee 1" PDF, instead of having 13 names on one PDF (how the code is currently written), it would be one page of five names (Group A) and then a second page of eight names (Group B) within the same "Employee 1" PDF.

Can anybody help out with a tweak in the code to make that a possibility?

Thank you!

EDIT: Updated Code:

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

Upvotes: 0

Views: 1581

Answers (1)

barryleajo
barryleajo

Reputation: 1952

As a follow-on from your previous thread, this modified code adds a hpage break, within a 'pdf', when 'group' changes. Copy the whole code rather than try amending existing; there are a few changes but too many to explain. For example I previously forgot to include Option Explicit and had to declare a couple of variables to prevent some 'Variable not defined' errors (tut, tut)! Works OK on my 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

Upvotes: 1

Related Questions