VBA-分类汇总

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