VBA 跨页打印设置

Sub 重组跨页合并()
    Dim P As HPageBreak, strAddress$, Val
    Dim ActSht As Worksheet, Cell As Range, Rng As Range, iCol&
    Application.ScreenUpdating = False
    Set ActSht = ActiveSheet '当前工作表
    Set Rng = Application.InputBox("选择需要重组所在的列", "Excel VBA 练习提示:", , , , , , 8)
    If Rng Is Nothing Then MsgBox "请重新选择!", 64, "提示!": Exit Sub
    If Rng.Columns.Count > 1 Then MsgBox "只能选取1列", 64, "提示!": Exit Sub
    iCol = Rng.Column
    ActiveWindow.View = xlPageBreakPreview '当前工作表进去分页预览
    With ActSht
        For Each P In .HPageBreaks '逐页循环
            Set Cell = .Cells(P.Location.Row - 1, iCol) '每个分页最后一个单元格赋值变量CELL
            If Cell.MergeCells And Not Intersect(Cells(P.Location.Row, iCol), Cell.MergeArea) Is Nothing Then
            '如果最后一个单元格具有合并属性与下一页中第一个单元格处于同一个合并单元格区域
                strAddress = Cell.MergeArea.Address '获取地址
                Val = Cell.MergeArea(1).Value '获取值
                Cell.MergeArea.UnMerge '取消合并
                With .Range(Range(strAddress)(1), Cell) '区域中属于本页的单元格
                    .Merge '合并
                    .Borders.LineStyle = 1 '添加边框
                End With
                With .Range(Cell.Offset(1), .Cells(Split(strAddress, "$")(4), iCol)) '下一页的单元格
                    .Merge '合并
                    .Value = Val '赋值
                    .Borders.LineStyle = 1 '添加边框
                    .HorizontalAlignment = -4108 '居中
                    .VerticalAlignment = -4108
                End With
            End If
        Next
    End With
    ActiveWindow.View = xlNormalView '设置会常规
    Application.ScreenUpdating = True
End Sub
复制