Excel VBA：复制指定区域时当前页无法容纳则跳转新页粘贴如何实现

实现方案 #

核心通过Excel VBA的HPageBreaks对象获取水平分页符的位置，从而计算每页的首行、末行行号，逻辑如下：

• 提前提取所有水平分页符的行号，存入数组用于快速查询
• 每次计算出待粘贴起始位置nextCell后，先判断从该行开始放下6行内容是否超出当前页的末行
• 若超出则直接将nextCell设置为下一页的首行再执行粘贴

完整修改后代码 #

Sub 重复粘贴带分页校验()
    Dim ws As Worksheet
    Dim i As Long, j As Long, n As Long, num_ranges As Long
    Dim nextCell As Range
    Dim pageBreakRows As Variant, pageCount As Long
    Const PASTE_ROW_COUNT As Long = 6 ' 待粘贴区域固定行数
    
    Set ws = ActiveSheet ' 可替换为实际工作表对象，比如Worksheets("你的表名")
    ws.DisplayPageBreaks = True ' 强制刷新分页符，确保获取的分页位置准确
    
    ' 预获取所有水平分页符的行号，分页符所在行是下一页的首行
    pageCount = ws.HPageBreaks.Count
    ReDim pageBreakRows(1 To pageCount)
    For i = 1 To pageCount
        pageBreakRows(i) = ws.HPageBreaks(i).Location.Row
    Next i
    
    For i = 1 + num_ranges To n
        ws.Range("newRange").Copy
        Set nextCell = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(2, 0)
        
        ' 校验当前页剩余空间是否足够
        Dim currentPageEndRow As Long, nextPageStartRow As Long
        ' 默认最后一页的末行取工作表最大行，有固定打印区域可自行修改为打印区域末行
        currentPageEndRow = ws.Rows.Count
        nextPageStartRow = ws.Rows.Count ' 最后一页没有下一页，默认取最大行
        ' 查找当前起始行所在页的末行
        For j = 1 To pageCount
            If pageBreakRows(j) > nextCell.Row Then
                currentPageEndRow = pageBreakRows(j) - 1
                nextPageStartRow = pageBreakRows(j)
                Exit For
            End If
        Next j
        
        ' 剩余空间不足，直接跳到下一页首行
        If (currentPageEndRow - nextCell.Row + 1) < PASTE_ROW_COUNT Then
            Set nextCell = ws.Cells(nextPageStartRow, "A")
        End If
        
        nextCell.PasteSpecial xlPasteAll
    Next i
    
    ' 清理剪贴板
    Application.CutCopyMode = False
End Sub

注意事项 #

• 分页符位置会自动适配工作表的打印区域、页边距、缩放比例设置，你可以先调整好打印参数再运行代码，分页逻辑会自动匹配你的打印规则
• 如果待粘贴区域的行数后续有调整，直接修改常量PASTE_ROW_COUNT的取值即可，无需修改其他逻辑

内容的提问来源于stack exchange，提问作者Jim Peng