适用于具备水平分页,无垂直分页的Excel工作表的情况。
尽量保持原工作表格式而采用建立副本的方法,代码存在优化的可能。
本文假设打印标题不低于两行。
Sub SplitWorkbookByPrintPages()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim i As Long
Dim lastRow As Long
Dim totalPageNumber As Long
Dim startRow As Long
Dim endRow As Long
Dim printTitleLastRow As Long
Dim printTitleRows As String
'Application.DisplayAlerts = False
' 设置源工作表
Set wsSource = ThisWorkbook.Sheets("Sheet1") ' 替换为您的工作表名称
' 获取总页数
totalPageNumber = wsSource.PageSetup.Pages.Count
' 获取打印标题行
printTitleRows = wsSource.PageSetup.printTitleRows
' 获取打印标题的最后一行
If printTitleRows <> "" Then
printTitleLastRow = Split(Split(printTitleRows, ":")(1), "$")(1)
Else
printTitleLastRow = 0
End If
' 获取最后一行
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
' 遍历每个水平分页符
For i = 1 To totalPageNumber
' 确定当前页的起始和结束行
If i = 1 Then
startRow = 1
Else
startRow = wsSource.HPageBreaks(i - 1).Location.Row
End If
If i < totalPageNumber Then
endRow = wsSource.HPageBreaks(i).Location.Row - 1
Else
endRow = lastRow
End If
' 创建新工作表(复制整个源工作表)
wsSource.Copy After:=Worksheets(Worksheets.Count)
Set wsDest = ActiveSheet
' 设置新工作表的名称
wsDest.Name = "Page " & i
' 删除不需要的行,但保留打印标题行
If totalPageNumber = 1 Then Exit Sub
If i = 1 Then wsDest.Rows(endRow + 1 & ":" & lastRow).Delete
If i > 1 Then
If printTitleLastRow > 0 Then
wsDest.Rows((printTitleLastRow + 1) & ":" & (startRow - 1)).Delete
Else
wsDest.Rows("1:" & (startRow - 1)).Delete
End If
End If
If i < totalPageNumber Then
wsDest.Rows((endRow - startRow + printTitleLastRow + 2) & ":" & lastRow).Delete
End If
' 在指定单元格设置动态内容:页码及总页数
wsDest.Range("E2").Value = "Page " & i & " of " & totalPageNumber
wsDest.Range("E2").Font.Bold = True
' 保持原始的打印标题设置
wsDest.PageSetup.printTitleRows = printTitleRows
' 调整打印区域
wsDest.PageSetup.PrintArea = wsDest.UsedRange.Address
Next i
' 删除源工作表(如果需要的话)
'wsSource.Delete
'Application.DisplayAlerts = True
End Sub
标签:Dim,End,预览,表并,printTitleRows,wsDest,totalPageNumber,页码,wsSource
From: https://www.cnblogs.com/geyee/p/18435871