求超过行数的拆表内容像分页一样生成新表

saoxu

求助，为了地磅打印方便，想在同一张表里实现分页。想达到的样子像最后一样表。

魂断蓝桥

Sub A()
Dim cnn, rs As Object, Sql As String, I%, r%
Set cnn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.Recordset")
cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr:=no';data source=" & ThisWorkbook.FullName
Sql = "select * from [地磅明细$a3:k] where F1 IS NOT NULL"
rs.Open Sql, cnn, 1, 1
Sheet34.Activate
ActiveSheet.ResetAllPageBreaks
Cells.Clear
Do While Not rs.EOF
    I = [a999].End(3).Row
    If I = 1 Then
        Sheet2.Range("A1:K3").Copy Range("A1").Offset((I - 1), 0)
         I = [a999].End(3).Row + 1
        Range("A1").Offset(I, 0).CopyFromRecordset rs, 15
          r = [a999].End(3).Row
        Range("A" & I & ":K" & r).Borders.LineStyle = xlContinuous
        Range("A4:K" & r).Borders.LineStyle = xlContinuous
        ActiveSheet.HPageBreaks.Add Before:=Cells(r + 2, 1)
    Else
        I = [a999].End(3).Row + 2
        Sheet2.Range("A1:K3").Copy Range("A1").Offset(I - 1, 0)
         I = [a999].End(3).Row + 2
        Range("A1").Offset(I - 1, 0).CopyFromRecordset rs, 15
        r = [a999].End(3).Row
        Range("A" & I & ":K" & r).Borders.LineStyle = xlContinuous
        ActiveSheet.HPageBreaks.Add Before:=Cells(r + 1, 1)
    End If
Loop
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End Sub

saoxu

谢谢魂断蓝桥侠圣，但我执行后的结果还是没有办法分类打印，我原来写在分类代码写在THISWORKBOOS能不能加上这段代码上去。