如何每隔10行插入标题行、表尾行

top396

请教各位大神，如何每隔10行插入相同格式的标题行，表尾行？标题行打印时，可固定打印，表尾行不带表格也可通过页脚设置。但页脚有一行带表格,无从下手。效果

清风竹-

请看附件。

top396

清风竹- 发表于 2020-8-3 19:00
请看附件。

你好，先谢谢！待会再试！

top396

清风竹- 发表于 2020-8-3 19:00
请看附件。

你好，大神，可以用了，但有个问题，能不能把VBA原代码给我一个，如碰到多一列少一列，我又蒙圈了！

top396

清风竹- 发表于 2020-8-3 19:00
请看附件。

Sub 生成表格()
On Error Resume Next
Application.ScreenUpdating = False
m = Sheet1.[a65536].End(3).Row
arr = Sheet1.Range("a1:j" & m + 10)
Rows("18:" & [a65536].End(3).Row + 2).Delete
If UBound(arr) Mod 10 = 0 Then
     p = m \ 10 - 1
Else
     p = m \ 10
End If
ReDim brr(1 To 10, 1 To 10)
      For i = 1 To p
         Rows("1:17").Select
         Selection.Copy
         Range("A" & i * 18 + 1).Select
         ActiveSheet.Paste
         Range("A" & i * 18 + 6).Resize(10, 10).ClearContents
       Next
   
    For i = 0 To p
        For j = 1 To 10
            For k = 1 To 10
                brr(j, k) = arr(i * 10 + j, k)
            Next
        Next
         Range("A" & i * 18 + 6).Resize(10, 10) = brr
       Next
    Range("a4").Select
   Application.ScreenUpdating = True    '页面刷新
End Sub

清风竹-

top396 发表于 2020-8-4 08:45
Sub 生成表格()
On Error Resume Next
Application.ScreenUpdating = False

用下边代码，替换原代码。

Sub 生成表格()
On Error Resume Next
Application.ScreenUpdating = False
m = Sheet1.[a65536].End(3).Row
arr = Sheet1.Range("a1:j" & m + 10)
Rows("18:" & [a65536].End(3).Row + 2).Delete
If UBound(arr) Mod 10 = 0 Then
     p = m \ 10 - 1
Else
     p = m \ 10
End If
   lie = 10  ''lie指列数 在这里修改列数,如:lie = 8或lie = 10或lie = 15或lie = 18等. 上行的p是页数
ReDim brr(1 To 10, 1 To lie) ''原代码右边的10指列数
      For i = 1 To p
         Rows("1:17").Select
         Selection.Copy
         Range("A" & i * 18 + 1).Select
         ActiveSheet.Paste
      
         Range("A" & i * 18 + 6).Resize(10, lie).ClearContents  ''''原代码Resize(10, 10)右边的10指列数
       Next
   
    For i = 0 To p
        For j = 1 To 10
            For k = 1 To lie   '''''原代码For k = 1 To 10  右边的10指列数
                brr(j, k) = arr(i * 10 + j, k)
            Next
        Next
         Range("A" & i * 18 + 6).Resize(10, lie) = brr  '''原代码Resize(10, 10)右边的10指列数
       Next
    Range("a4").Select
   Application.ScreenUpdating = True    '页面刷新
End Sub

准提部林

沒有那麼複雜, 保留1~17行的格式及標題+底標:
Sub TEST()
Dim R&, xR As Range, i&
Call ClaerAll
Set xR = Sheet2.[A1]
R = Sheet1.[B65536].End(xlUp).Row
For i = 1 To R Step 10
    If i > 1 Then Sheet2.Rows("1:17").Copy xR
    xR(6).Resize(10, 10) = Sheet1.Cells(i, 1).Resize(10, 10).Value
    Set xR = xR(18)
Next i
End Sub
'==============================
Sub ClaerAll()
With Sheet2
     .UsedRange.Offset(17, 0).EntireRow.Delete
     .Range("A6:J15").ClearContents
     .[A1].Select
End With
End Sub

Xl0000287.rar (21.7 KB, 下载次数: 39)

2020-8-4 19:07 上传

点击文件名下载附件

top396

谢谢，两位大神，问题已解决

zhon77

准提部林 发表于 2020-8-4 19:08
沒有那麼複雜, 保留1~17行的格式及標題+底標:
Sub TEST()
Dim R&, xR As Range, i&

请教大神，如果行数和列数都改变，这个该怎么做。 样表.rar (11.29 KB, 下载次数: 0)

2024-4-16 21:58 上传

点击文件名下载附件

zhon77

清风竹- 发表于 2020-8-4 16:57
用下边代码，替换原代码。

Sub 生成表格()

请教大神，如果行数和列数都改变，这个该怎么做。 样表.rar (11.29 KB, 下载次数: 1)

2024-4-16 21:59 上传

点击文件名下载附件