VBA实现汇总后，怎么能体现小计行

nostopping

VBA实现汇总后，怎么能体现小计行
数据多，已用VBA实现了汇总功能，怎么改善代码出现小计行，如附件中图所示

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, p, m, sum, total
  arr = Sheets("原表").[a1].CurrentRegion.Offset(1).Resize(, 5)
  ReDim brr(1 To UBound(arr, 1) * 2, 1 To UBound(arr, 2))
  ReDim sum(UBound(arr, 2)), total(UBound(arr, 2)), crr(UBound(arr, 2))
  Call bsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
  For i = 1 To UBound(arr, 1) - 1
    If arr(i, 1) <> arr(i + 1, 1) Then
      Call bsort(arr, p + 1, i, 1, UBound(arr, 2), 2)
      For j = p + 1 To i
        For k = 3 To UBound(arr, 2)
          sum(k) = sum(k) + arr(j, k)
          total(k) = total(k) + arr(j, k)
        Next
        If j = i Or arr(j, 2) <> arr(j + 1, 2) Then
          m = m + 1
          brr(m, 1) = arr(j, 1): brr(m, 2) = arr(j, 2)
          For k = 3 To UBound(arr, 2)
            brr(m, k) = sum(k): sum(k) = 0
          Next
          If j = i Then
            m = m + 1
            brr(m, 1) = arr(j, 1): brr(m, 2) = "小计"
            For k = 3 To UBound(arr, 2)
              brr(m, k) = total(k)
              crr(k) = crr(k) + total(k): total(k) = 0
            Next
          End If
        End If
      Next
      p = i
    End If
  Next
  m = m + 1: brr(m, 2) = "总计"
  For i = 3 To UBound(arr, 2)
    brr(m, i) = crr(i)
  Next
  With Sheets("汇总").[g4]
    .Resize(Rows.Count - 3, UBound(brr, 2)).ClearContents
    .Resize(m, UBound(brr, 2)) = brr
  End With
  Sheets("原表").[a1].Resize(, UBound(arr, 2)).Copy Sheets("汇总").[g3]
End Sub

Function bsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If StrComp(arr(j, key), arr(j + 1, key), vbTextCompare) = 1 Then
        For k = left To right
          t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
        Next
      End If
    Next
  Next
End Function

cqcbc

一把小刀闯天下 发表于 2019-10-14 06:48
Option Explicit

Sub test()

不错，小刀老师，能不能再延伸一下，同时将A列也添加小计行，即按“系列”小计一下。

一把小刀闯天下

cqcbc 发表于 2019-10-14 07:29
不错，小刀老师，能不能再延伸一下，同时将A列也添加小计行，即按“系列”小计一下。

没看懂。已经有分计、小计、总计了

A系列为小计和总计，都已经显示。好好看一下一楼图就知道是怎么回事了

-------------
当然也可以上附件作图示

cqcbc

一把小刀闯天下 发表于 2019-10-14 08:45
没看懂。已经有分计、小计、总计了

A系列为小计和总计，都已经显示。好好看一下一楼图就知道是怎么回 ...

哦，我搞错了，我请求的事项应该是：先汇总同一系列的B列，再汇总同一系列（A列），如附件。原表我已按A、B列排序了。请老师帮助实现。


对了，我的要求是：插入式，保留了原有的行。

一把小刀闯天下

cqcbc 发表于 2019-10-14 07:29
不错，小刀老师，能不能再延伸一下，同时将A列也添加小计行，即按“系列”小计一下。

'假设A、B列有序，不然还要排序，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, p, m, sum, total
  arr = Sheets("原表").[a1].CurrentRegion.Offset(1).Resize(, 5)
  ReDim brr(1 To UBound(arr, 1) * 2, 1 To UBound(arr, 2))
  ReDim sum(UBound(arr, 2)), total(UBound(arr, 2)), crr(UBound(arr, 2))
  For i = 1 To UBound(arr, 1) - 1
    m = m + 1
    For j = 1 To UBound(arr, 2)
      brr(m, j) = arr(i, j)
      If j > 2 Then
        sum(j) = sum(j) + arr(i, j)
        total(j) = total(j) + arr(i, j)
        crr(j) = crr(j) + arr(i, j)
      End If
    Next
    If arr(i, 1) <> arr(i + 1, 1) Or arr(i, 2) <> arr(i + 1, 2) Then
      m = m + 1: brr(m, 2) = arr(i, 2) & "汇总"
      For j = 3 To UBound(arr, 2)
        brr(m, j) = sum(j): sum(j) = 0
      Next
      If arr(i, 1) <> arr(i + 1, 1) Then
        m = m + 1: brr(m, 1) = arr(i, 1) & "汇总"
        For j = 3 To UBound(arr, 2)
          brr(m, j) = total(j): total(j) = 0
        Next
      End If
    End If
  Next
  m = m + 1: brr(m, 1) = "总计"
  For i = 3 To UBound(arr, 2)
    brr(m, i) = crr(i)
  Next
  With Sheets("汇总").[g4]
    .Resize(Rows.Count - 3, UBound(brr, 2)).ClearContents
    .Resize(m, UBound(brr, 2)) = brr
  End With
  Sheets("原表").[a1].Resize(, UBound(arr, 2)).Copy Sheets("汇总").[g3]
End Sub

cqcbc

一把小刀闯天下 发表于 2019-10-14 10:42
'假设A、B列有序，不然还要排序，，，

Option Explicit

佩服，真的厉害！谢谢！

blackttea1

谢谢分享！

cqcbc

一把小刀闯天下 发表于 2019-10-14 10:42
'假设A、B列有序，不然还要排序，，，

Option Explicit

再请老师帮忙，新增加了一列，字段“业务员”，A、B、C列已排序。要求也统计出来，自己试着修改VBA，没有成功，希望能修改一下，我也好对照学习。

一把小刀闯天下

cqcbc 发表于 2019-10-14 16:47
再请老师帮忙，新增加了一列，字段“业务员”，A、B、C列已排序。要求也统计出来，自己试着修改VBA，没有 ...

看了一下，有4个层级都晕了。不应该是楼主的马甲吧，觉得自己开个主题帖会更好，看看别人的建议，，，