Excel VBA通过在多个PDF中分组来创建分页符 [英] Excel VBA to Create Page Breaks by Grouping Within Multiple PDFs
问题描述
我目前拥有四列的 Excel表格 ：名字（A），姓氏（B），组（C）和PDF（D）。感谢另一个线程的帮助，我们能够以确保以下VBA代码，根据列D将电子表格完美分割成多个PDF：
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
此代码完美地将Excel表格分解成基于D列的分页符，并将它们作为单独的PDF将它们拍摄到正确的输出 - 只剩下一个。列C（组）与列D非常相似，但是当我不想要每个组的个性化PDF时，我希望每个单独的PDF（从D列）到C组的分页符。例如，对于雇员1PDF，而不是在一张PDF上有13个名字（如何编写代码），它将是一页五个名字（A组），然后是第八页（B组）的第二页相同的员工1PDF。
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?
谢谢！
编辑：更新代码：
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
推荐答案
从以前的线程中进行跟踪，当组更改时，此修改后的代码会在pdf中添加一个hpage break。复制整个代码，而不是尝试修改现有的;有一些变化，但太多，不能解释。例如，我以前忘记包含 Option Explicit ，并且必须声明一些变量来防止一些变量未定义错误（tut，tut）！在我的MacBook上工作正常。
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
这篇关于Excel VBA通过在多个PDF中分组来创建分页符的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
