强制分页并插入标题栏问题？

xus123

如题，如何给工作表强制分页，并插入标题栏？如果不能解决插入标题栏的问题的话，可以先解决强制分页问题，非常感谢！

3190496160

Sub 分页()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim rn As Range
Dim arr()
Set sh = Sheets("打印")
With sh
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    ar = .Range("a1:h" & r)
    Set rn = .Rows("1:5")
End With
ReDim arr(1 To UBound(ar), 1 To 2)
For i = 1 To UBound(ar)
    If InStr(ar(i, 1), "销售单") > 0 Then
        n = n + 1
        arr(n, 1) = i
    End If
    If InStr(ar(i, 2), "验收人") > 0 Then
        arr(n, 2) = i
    End If
Next i
If n = "" Then MsgBox "数据源中缺少标识符！": End
rs = 1
With Sheets("打印模板")
    .UsedRange.Borders.LineStyle = 0
    .UsedRange = Empty
    .Rows("1:10000").RowHeight = 22
    For i = 1 To n
        ks = arr(i, 1) + 5
        js = arr(i, 2) - 3
        br = sh.Range("a" & ks & ":h" & js)
        If UBound(br) <= 30 Then
            rn.Copy .Cells(rs, 1)
            .Cells(rs + 3, 7) = ar(ks - 2, 7)
            .Cells(rs + 5, 1).Resize(UBound(br), UBound(br, 2)) = br
            .Cells(rs + 5, 1).Resize(UBound(br) + 1, UBound(br, 2)).Borders.LineStyle = 1
            .Cells(rs + 5 + UBound(br), 2) = "合计"
            .Cells(rs + 5 + UBound(br), 5) = Application.Sum(Application.Index(br, 0, 5))
            .Cells(rs + 5 + UBound(br), 7) = Application.Sum(Application.Index(br, 0, 7))
            .Cells(rs + 7 + UBound(br), 5) = "验收人："
            .Cells(rs + 7 + UBound(br), 7) = "送货人："
            rs = rs + 38
        Else
            For s = 1 To UBound(br) Step 30
                rn.Copy .Cells(rs, 1)
                .Cells(rs + 3, 7) = ar(ks - 2, 7)
                m = rs + 4
                kk = 0
                hj_1 = 0: hj_2 = 0
                For ss = s To s + 29
                    If ss <= UBound(br) Then
                        m = m + 1
                        kk = kk + 1
                        hj_1 = hj_1 + br(ss, 5)
                        hj_2 = hj_2 + br(ss, 7)
                        For j = 1 To 8
                            .Cells(m, j) = br(ss, j)
                        Next j
                    End If
                Next ss
                .Cells(m + 1, 2) = "合计"
                .Cells(m + 1, 5) = hj_1
                .Cells(m + 1, 7) = hj_2
                .Cells(rs + 5, 1).Resize(kk + 1, UBound(br, 2)).Borders.LineStyle = 1
                .Cells(m + 3, 5) = "验收人："
                .Cells(m + 3, 7) = "送货人："
                rs = rs + 38
            Next s
        End If
    Next i
    .Columns("i:j").Delete
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

强制分页并插入标题栏问题.rar (91.38 KB, 下载次数: 15)

2024-1-19 09:17 上传

点击文件名下载附件

xus123

3190496160 发表于 2024-1-19 09:17

非常感谢“3190496160”老师的帮助！