Excel VBA通过在多个PDF中分组来创build分页符
我目前有一个Excel表，有四列：名字（A），姓氏（B），组（C）和PDF（D）。 得益于另一个线程的帮助，我们能够确保以下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列的分页符。例如，对于在一个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
作为前一个线程的后续内容，当“组”更改时，此修改后的代码将在“pdf”内添加一个hpage分隔符。 复制整个代码，而不是尝试修改现有的; 有一些变化，但太多解释。 例如我以前忘了包括Option Explicit并且必须声明一些variables来防止一些'Variable not defined'错误（tut，tut）！ 在我的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