打印底注行（底端标题行）完美版

cbtaja

功能完整、且简单易用的打印底注行（底端标题行）工具

EXCEL页面设置中包含了“打印标题”（PrintTitle)的设置，这为避免重复输入顶端标题行带来了很大方便。
但是，表格中除了打印“标题行”之外，往往还需要在每页底部附加“签字栏”等这样相对类似于“标题行”而存在的“底注行”。
而美中不足的是，EXCEL并没有内置该项页面设置功能。因此，强大的坛友们中编写了很多类似的“底端标题行”工具。
本人也来编写一个。虽然本工具颇有特色，但标题中号称“完美”，其实只是为了抛砖引玉而已。
下一步将添加用户菜单功能，请大家测试和提出修改意见。

打印底注行（底端标题行）.rar (89.52 KB, 下载次数: 2685)

2016-7-8 17:02 上传

点击文件名下载附件

1. '------------------------------------------------------------------------------
   
2. ' 程序名称  :     PrintAnnotationsRows
   
3. ' 中文名称  :     设置打印底注行
   
4. ' 修改时间  :     2016-7-7 12:00
   
5. '------------------------------------------------------------------------------
   
6. ' 作者      :     cbtaja（极速蜗牛）
   
7. ' Email     :     dengsch@foxmail.com
   
8. '------------------------------------------------------------------------------
   
9. ' 使用环境  :     Excel 2003及以上版本。
   
10. ' 程序功能  :     为EXCEL补充“打印底注”功能（相对于系统内置的“打印标题”功能）
    
11. ' 程序原理  :     首先，把“打印底注行”合并到“打印标题行”中，
    
12. '                 以便借用系统来完成自动分页；
    
13. '                 然后，把“底注行”复制到各分页处,；
    
14. '                 最后，删除标题行中的“底注行”，完成目标。
    
15. ' 程序特色  :     1、分页准确无误（因由系统实现自动分页，无计算误差）；
    
16. '                 2、适应EXCEL2003以上全系列版本；
    
17. '                 3、适应所有工作表的格式：
    
18. '                   不对原表格格式作任何限制，即可以设置任意行数的标题行和底注行，
    
19. '                   且不限制标题行的起始行号；可一键复原；
    
20. '                 4、功能完善，无需任何其它第三方软件辅助；
    
21. '                 5、可一次预览所有打印页，不仅避免仅逐页预览的麻烦，
    
22. '                   还避免逐页预览不能在页眉、页脚显示总页码的错误；
    
23. '                 5、简单易用，人性化的交互功能，使得点击鼠标3次即可完成操作；
    
24. '                 6、单文件，代码简单、且不含“用户窗体”，使用和移植都方便；
    
25. '                 7、免费、开源；
    
26. '------------------------------------------------------------------------------
    
27. 
    
28. 
    
29. Option Explicit
    
30. Sub PrintAnnotationsRows() '设置打印底注行
    
31.     Dim PrintAnnotationsRows As Range, rCount&, rNums&()
    
32.     Dim PAnttRowsCount&, endRow As Range, PtRows As Range
    
33.     Dim PtRowsAddress$, PTRowsCount&, i&, t#, iEndCellRow&
    
34.    
    
35.     If MsgBox("是否自动复制到新表中处理？", vbYesNo) = vbYes Then _
    
36.     ActiveSheet.Copy after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
    
37.     ActiveSheet.Columns.Find("*", , xlValues, , , 2).EntireRow.Cells(1).Select
    
38.     On Error Resume Next
    
39.     Set PrintAnnotationsRows = Application.InputBox("请指定底端附注行：", _
    
40.         "设置底端标题", Type:=8).EntireRow
    
41.     If Err.Number Then Exit Sub
    
42.    
    
43.     PAnttRowsCount = PrintAnnotationsRows.Rows.Count
    
44.     Set endRow = PrintAnnotationsRows.Offset(-1).Resize(1)
    
45.    
    
46.     t = Timer
    
47.     '首先，把底端附注行剪切至顶端标题行之上，并把该行加入到顶端标题行中
    
48.     PrintAnnotationsRows.Cut
    
49.     With PrintAnnotationsRows.Parent
    
50.         PtRowsAddress = .PageSetup.PrintTitleRows '顶端标题行
    
51.         If Len(PtRowsAddress) = 0 Then
    
52.             Set PtRows = .Rows(1)
    
53.             PTRowsCount = 0
    
54.            Else
    
55.             Set PtRows = .Rows(PtRowsAddress)
    
56.             PTRowsCount = PtRows.Rows.Count
    
57.         End If
    
58.         PtRows.Insert Shift:=xlDown
    
59.         .PageSetup.PrintTitleRows = PrintAnnotationsRows.Resize(PAnttRowsCount + _
    
60.             PTRowsCount).Address
    
61.         Application.ScreenUpdating = False
    
62.         
    
63.         '然后，根据系统自动分页结果，把包含水平分页符的行号记录以数组中
    
64.         iEndCellRow = .Cells.Find("*", , xlValues, , , 2).Row
    
65.         For i = 1 To iEndCellRow
    
66.             If Rows(i).PageBreak <> xlNone Then
    
67.                 rCount = rCount + 1
    
68.                 ReDim Preserve rNums(1 To rCount)
    
69.                 rNums(rCount) = i
    
70.             End If
    
71.         Next
    
72.         
    
73. '       由下向上，在每个水平分页符下面添加底注行
    
74.         PrintAnnotationsRows.Copy
    
75.         endRow.Offset(1).Insert Shift:=xlUp
    
76.         For i = rCount To 1 Step -1
    
77.             PrintAnnotationsRows.Copy
    
78.             .Rows(rNums(i)).Insert Shift:=xlDown
    
79.         Next
    
80.         
    
81.         '最后，从顶端标题行中删除原本除属于底注的行
    
82.         PrintAnnotationsRows.Delete
    
83.         
    
84.         Application.CutCopyMode = False
    
85.         Application.ScreenUpdating = True
    
86.         .Cells(1).Select
    
87.     End With
    
88.     t = Timer - t
    
89.     MsgBox Format(t, "用时0.0秒！")
    
90.     Call PrintPreview
    
91. End Sub
    
92. 
    
93. Private Sub PrintPreview() '打印预览
    
94.     ActiveWindow.SelectedSheets.PrintOut , , , True
    
95. End Sub
    
96. 
    
97. Sub RemoveDuplicateAnnotation() '删除重复的底注或标题行（表格复原功能）
    
98.     Dim PrintAnnotationsRows As Range '
    
99.     Dim ss As Worksheet, j&, s$, i&, s0$, arr, nPARowsCount&, iPARow&
    
100.     On Error Resume Next
     
101.     ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Select
     
102.     Set PrintAnnotationsRows = Application.InputBox("请指定底端附注行区域：", _
     
103.         "设置底端标题", Type:=8).EntireRow
     
104.     If Err.Number Then Exit Sub
     
105.     Application.ScreenUpdating = False
     
106.     Set ss = PrintAnnotationsRows.Parent
     
107.     arr = PrintAnnotationsRows.Resize(1, 12)
     
108.     For j = 1 To 12
     
109.         s = s & arr(1, j)
     
110.     Next
     
111.     nPARowsCount = PrintAnnotationsRows.Rows.Count
     
112.     With ss
     
113.         iPARow = PrintAnnotationsRows.Offset(-1).Cells(1).Row
     
114.         For i = iPARow To 1 Step -1
     
115.             arr = .Cells(i, 1).Resize(1, 12)
     
116.             s0 = ""
     
117.             For j = 1 To 12
     
118.                 s0 = s0 & arr(1, j)
     
119.             Next
     
120.             If s = s0 Then .Rows(i).Resize(nPARowsCount).Delete
     
121.         Next
     
122.         Application.ScreenUpdating = True
     
123.         .Cells(1).Select
     
124.     End With
     
125. End Sub
     

复制代码

thzss

好东西，这下子方便多了

thzss

测试了一下，用时都在10秒以上

d346836673

好动西  收藏了

lpxkk

好东西，这下子方便多了

认真的雪8686

怎么用的啊

chengshanming

不错的帖子，收藏了！

a007lin

求使用方法

jjttjj01

很不错的功能！

ggmmlol

帮楼主优化一下代码，效率提高4倍！

1. '------------------------------------------------------------------------------
   
2. ' 程序名称  :     PrintAnnotationsRows
   
3. ' 中文名称  :     设置打印底注行
   
4. ' 修改时间  :     2016-7-7 12:00
   
5. '------------------------------------------------------------------------------
   
6. ' 作者      :     cbtaja（极速蜗牛）
   
7. ' Email     :     dengsch@foxmail.com
   
8. '------------------------------------------------------------------------------
   
9. ' 使用环境  :     Excel 2003及以上版本。
   
10. ' 程序功能  :     为EXCEL补充“打印底注”功能（相对于系统内置的“打印标题”功能）
    
11. ' 程序原理  :     首先，把“打印底注行”合并到“打印标题行”中，
    
12. '                 以便借用系统来完成自动分页；
    
13. '                 然后，把“底注行”复制到各分页处,；
    
14. '                 最后，删除标题行中的“底注行”，完成目标。
    
15. ' 程序特色  :     1、分页准确无误（因由系统实现自动分页，无计算误差）；
    
16. '                 2、适应EXCEL2003以上全系列版本；
    
17. '                 3、适应所有工作表的格式：
    
18. '                   不对原表格格式作任何限制，即可以设置任意行数的标题行和底注行，
    
19. '                   且不限制标题行的起始行号；可一键复原；
    
20. '                 4、功能完善，无需任何其它第三方软件辅助；
    
21. '                 5、可一次预览所有打印页，不仅避免仅逐页预览的麻烦，
    
22. '                   还避免逐页预览不能在页眉、页脚显示总页码的错误；
    
23. '                 5、简单易用，人性化的交互功能，使得点击鼠标3次即可完成操作；
    
24. '                 6、单文件，代码简单、且不含“用户窗体”，使用和移植都方便；
    
25. '                 7、免费、开源；
    
26. '------------------------------------------------------------------------------
    
27. 
    
28. 
    
29. Option Explicit
    
30. Sub PrintAnnotationsRows() '设置打印底注行
    
31.     Dim PrintAnnotationsRows As Range, rCount&, rNums&()
    
32.     Dim PAnttRowsCount&, endRow As Range, PtRows As Range
    
33.     Dim PtRowsAddress$, PTRowsCount&, i&, t#, iEndCellRow&
    
34. 
    
35.     If MsgBox("是否自动复制到新表中处理？", vbYesNo) = vbYes Then _
    
36.     ActiveSheet.Copy after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
    
37.     ActiveSheet.Columns.Find("*", , xlValues, , , 2).EntireRow.Cells(1).Select
    
38.     On Error Resume Next
    
39.     Set PrintAnnotationsRows = Application.InputBox("请指定底端附注行：", _
    
40.         "设置底端标题", Type:=8).EntireRow
    
41.     If Err.Number Then Exit Sub
    
42. 
    
43.     PAnttRowsCount = PrintAnnotationsRows.Rows.Count
    
44.     Set endRow = PrintAnnotationsRows.Offset(-1).Resize(1)
    
45. 
    
46.     t = Timer
    
47.     '首先，把底端附注行剪切至顶端标题行之上，并把该行加入到顶端标题行中
    
48.     PrintAnnotationsRows.Cut
    
49.     With PrintAnnotationsRows.Parent
    
50.         PtRowsAddress = .PageSetup.PrintTitleRows '顶端标题行
    
51.         If Len(PtRowsAddress) = 0 Then
    
52.             Set PtRows = .Rows(1)
    
53.             PTRowsCount = 0
    
54.            Else
    
55.             Set PtRows = .Rows(PtRowsAddress)
    
56.             PTRowsCount = PtRows.Rows.Count
    
57.         End If
    
58.         PtRows.Insert Shift:=xlDown
    
59.         .PageSetup.PrintTitleRows = PrintAnnotationsRows.Resize(PAnttRowsCount + _
    
60.             PTRowsCount).Address
    
61.         Application.ScreenUpdating = False
    
62. 
    
63.         Dim HPB As HPageBreak
    
64.         For Each HPB In .HPageBreaks
    
65.             rCount = rCount + 1
    
66.             ReDim Preserve rNums(1 To rCount)
    
67.             rNums(rCount) = HPB.Location.Row
    
68.         Next
    
69. 
    
70. 
    
71. 
    
72. '       由下向上，在每个水平分页符下面添加底注行
    
73.         PrintAnnotationsRows.Copy
    
74.         endRow.Offset(1).Insert Shift:=xlUp
    
75.         For i = rCount To 1 Step -1
    
76.             PrintAnnotationsRows.Copy
    
77.             .Rows(rNums(i)).Insert Shift:=xlDown
    
78.         Next
    
79. 
    
80.         '最后，从顶端标题行中删除原本除属于底注的行
    
81.         PrintAnnotationsRows.Delete
    
82. 
    
83.         Application.CutCopyMode = False
    
84.         Application.ScreenUpdating = True
    
85.         .Cells(1).Select
    
86.     End With
    
87.     t = Timer - t
    
88.     MsgBox Format(t, "用时0.0秒！")
    
89.     Call PrintPreview
    
90. End Sub
    
91. 
    
92. Sub PrintPreview() '打印预览
    
93.     ActiveWindow.SelectedSheets.PrintOut , , , True
    
94. End Sub
    
95. 
    
96. Sub RemoveDuplicateAnnotation() '删除重复的底注或标题行（表格复原功能）
    
97.     Dim PrintAnnotationsRows As Range '
    
98.     Dim ss As Worksheet, j&, s$, i&, s0$, arr, nPARowsCount&, iPARow&
    
99.     On Error Resume Next
    
100.     ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Select
     
101.     Set PrintAnnotationsRows = Application.InputBox("请指定底端附注行区域：", _
     
102.         "设置底端标题", Type:=8).EntireRow
     
103.     If Err.Number Then Exit Sub
     
104.     Application.ScreenUpdating = False
     
105.     Set ss = PrintAnnotationsRows.Parent
     
106.     arr = PrintAnnotationsRows.Resize(1, 12)
     
107.     For j = 1 To 12
     
108.         s = s & arr(1, j)
     
109.     Next
     
110.     nPARowsCount = PrintAnnotationsRows.Rows.Count
     
111.     With ss
     
112.         iPARow = PrintAnnotationsRows.Offset(-1).Cells(1).Row
     
113.         arr = .Range("A1").Resize(iPARow, 12)
     
114.         For i = iPARow To 1 Step -1
     
115.             s0 = ""
     
116.             For j = 1 To 12
     
117.                 s0 = s0 & arr(i, j)
     
118.             Next
     
119.             If s = s0 Then .Rows(i).Resize(nPARowsCount).Delete
     
120.         Next
     
121.         Application.ScreenUpdating = True
     
122.         .Cells(1).Select
     
123.     End With
     
124. End Sub

复制代码