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

VBA-分类汇总,布布扣,bubuko.com