Sub 分页小计()
If ActiveSheet.ProtectContents
Then MsgBox "工作表已保护,本程序拒绝执行！", 64, "提示": Exit
Sub
Dim columm As String, colunn As String,
Title_Rows As Byte, EndRow As Long, FenYeFu_Row As Long, XiaoJiRow As Integer, i
As Integer, j As Byte, str1 As Byte, str2 As Byte, LJrow As
Integer
If WorksheetFunction.CountA("a:b") = 0 Then
MsgBox "A、B列为空，无法建立分页小计。", 64, "提示": Exit Sub
On
Error Resume Next
AA =
WorksheetFunction.Substitute(Cells(1,
ActiveSheet.UsedRange.Columns.Count).Address(0, 0), 1,
"") ‘获取最后一个非空列的列标
Title_Rows =
Range(ActiveSheet.PageSetup.PrintTitleRows).Rows.Count ‘获取顶端标题的行数
If
err.Number = 1004 Then Title_Rows =
0 ‘如果不存在顶端标题则为0
err.Clear ‘清除错误设置
columm
= Application.InputBox("请输入需要汇总之首列列标（必须是英文字母），" & Chr(10) &
"将从该列开始产生小计及累计和。" & Chr(10) & "如果你只需要汇总一列，请在汇总末列处输入同样列标即可。", "汇总首列",
"C", , , , , 2)
If columm Like "[!a-zA-Z]" Then
MsgBox "对不起,您只能输入A-Z的字母。", vbOKOnly + 64, "提示": Exit
Sub
colunn =
Application.InputBox("请输入需要汇总之末列列标（必须是英文字母），" & Chr(10) &
"将从首列至此列之间的单元格产生小计及累计和。", "汇总末列", AA, , , , , 2)
If
colunn Like "[!a-zA-Z]" Then MsgBox "对不起,您只能输入A-Z的字母。", vbOKOnly + 64, "提示":
Exit Sub
On Error GoTo
err
str1 = Range(columm &
1).Column ‘将列标转换成数值
str2 = Range(colunn
& 1).Column ‘将列标转换成数值
If str2 <
str1 Then MsgBox "末列不能小于首列！", 64, "友情提示": Exit
Sub
XiaoJiRow =
2 ‘第一次赋值T为2，T的值等于小计、累计的总行数
ActiveSheet.ResetAllPageBreaks ‘重设分页符，它可以让工作表自动产生分页符，且以前设置的不规范的分页符可以删除
If
Application.ExecuteExcel4Macro("Get.Document(50)") > 1
Then ‘利用宏表函数计算当前表的页数，如果大于1页
i =
Application.ExecuteExcel4Macro("INDEX(GET.DOCUMENT(64),1)") - 1
‘每页（不含最后一行）行数。
Else
MsgBox "对不起，您的文件不足一页，此功能无效。", vbOKOnly + 64, "提示"
Exit Sub ‘只有1页则退出程序
End
If
AA = Timer
‘记录当前时间
Application.Calculation =
xlCalculationManual ‘手动计算
Application.StatusBar
= "★★★★ 正在生成小计与累计，请稍候...... ★★★★" ‘在状态栏显示当前状态
Application.ScreenUpdating =
False ‘关闭屏幕更新
EndRow =
ActiveSheet.UsedRange.Rows.Count ‘记录最后一个非空行的行号
X
= i - Title_Rows
‘每页行数减标题行行数
FenYeFu_Row =
i
‘每页最后一行行号。（此处为第一页最后一行的行号）
Do While EndRow
>= FenYeFu_Row ‘只要最后一个非空行大于当前页分页符所在行就一直循环下去
Rows((FenYeFu_Row - 1) & ":" & FenYeFu_Row).Insert
Shift:=xlDown ‘插入2行
Cells(FenYeFu_Row -
1, 1).Resize(2, 1) = [{"本页小计"; "累
计"}] ‘写入标题，纵向两个单元格分别产生小计与累计
Range(columm & (FenYeFu_Row - 1) & ":" & colunn & (FenYeFu_Row -
1)).Formula = "=SUM(R[-" + CStr(X - 2) + "]C:R[-1]C)"
‘设置合计公式
Range(columm & FenYeFu_Row &
":" & colunn & FenYeFu_Row).Formula = IIf(XiaoJiRow = 2, "=R[-1]C",
"=SUM(R[-" + CStr(X) + "]C:R[-2]C)")
ActiveWindow.SelectedSheets.HPageBreaks.Add before:=Rows(FenYeFu_Row +
1) ‘添加分页符
FenYeFu_Row = XiaoJiRow * X +
Title_Rows ‘累加变量FenYeFu_Row，其数值为每页行数的倍数
XiaoJiRow
= XiaoJiRow + 1
EndRow = EndRow + 2 ‘对变量 EndRow
累加2，因为插入了两行
Loop
‘再添加最后一页的小计
EndRow
=
ActiveSheet.UsedRange.Rows.Count ‘记录最后一行的行号
LJrow
= Evaluate("=MAX((a1:a" & Rows.Count & "=""累 计"")*ROW(1:"
& Rows.Count & "))")
Range(columm &
(EndRow + 1) & ":" & colunn & (EndRow + 1)).Formula = "=SUM(R[-" +
CStr(EndRow - LJrow) + "]C:R[-1]C)"
Range(columm
& (EndRow + 2) & ":" & colunn & (EndRow + 2)).Formula =
"=SUM(R[-" + CStr(EndRow - LJrow + 2) +
"]C:R[-2]C)"
Cells(EndRow + 1, 1).Resize(2, 1) =
[{"本页小计"; "累
计"}] ‘写入标题，纵向两个单元格分别产生小计与累计
‘添加边框
Range(Cells(EndRow
+ 1, 1), Cells(EndRow + 2,
ActiveSheet.UsedRange.Columns.Count)).Borders.LineStyle =
xlContinuous
Columns("A:A").HorizontalAlignment =
xlLeft ‘A列左对齐
Cells(1,
1).Select ‘返回A1
ActiveSheet.PageSetup.PrintArea
= Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Address
‘设定打印区域
MsgBox "程序共运行了" & Format(Timer -
AA, "0.00") &
"秒" ‘提示时间
Application.StatusBar =
"" ‘恢复状态栏
Application.Calculation =
xlCalculationAutomatic ‘自动计算
err:
ActiveWindow.View
=
xlNormalView ‘还原为常规视图
Application.ScreenUpdating
= True ‘恢复屏幕更新
If err <> 0 Then
MsgBox "出错原因可能有：" & Chr(10) & "1.指定的首尾列标大于Excel允许的最大列。" & Chr(10)
& "2.您的工作表纵向页数不超过1页！" & Chr(10) & "3.输入起止列时，您选择了取消！", 64,
"程序出错"
End Sub
Public Sub
删除小计()
On Error Resume
Next ‘将小计与累计会换成逻辑值，再定位于常量逻辑值，删除整行
Range("a:a").Replace
What:="本页小计", Replacement:="true", LookAt:=xlPart,
SearchOrder:=xlByRows
Range("a:a").Replace
What:="累 计", Replacement:="true", LookAt:=xlPart,
SearchOrder:=xlByRows
Range("a:a").SpecialCells(xlCellTypeConstants,
4).EntireRow.Delete
End Sub
原文地址：http://www.cnblogs.com/qiqingnan/p/3764117.html
