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

micch

Excel自带的分类汇总，直接生成？？？？

wowo000

帮你顶，期待哪位老师解决！

cqcbc

一把小刀闯天下 发表于 2019-10-14 19:24
看了一下，有4个层级都晕了。不应该是楼主的马甲吧，觉得自己开个主题帖会更好，看看别人的建议，，，

怎么会是马甲呢，你的建议，我会考虑的，但我还是希望照老师的步骤，跟着学习一下，再次谢谢。

一把小刀闯天下

cqcbc 发表于 2019-10-14 20:39
怎么会是马甲呢，你的建议，我会考虑的，但我还是希望照老师的步骤，跟着学习一下，再次谢谢。

'凑了一个，看上去应该差不多，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, p, m, sum, total
  arr = Sheets("原表").[a1].CurrentRegion.Offset(1).Resize(, 6)
  ReDim brr(1 To UBound(arr, 1) * 3, 1 To UBound(arr, 2))
  ReDim sum(UBound(arr, 2)), total(UBound(arr, 2)), crr(UBound(arr, 2)), drr(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 > 3 Then
        sum(j) = sum(j) + arr(i, j)
        total(j) = total(j) + arr(i, j)
        crr(j) = crr(j) + arr(i, j)
        drr(j) = drr(j) + arr(i, j)
      End If
    Next
    If arr(i, 1) <> arr(i + 1, 1) Or arr(i, 2) <> arr(i + 1, 2) Or arr(i, 3) <> arr(i + 1, 3) Then
      m = m + 1: brr(m, 3) = arr(i, 3) & Space(1) & "汇总"
      For j = 4 To UBound(arr, 2)
        brr(m, j) = sum(j): sum(j) = 0
      Next
      If arr(i, 2) <> arr(i + 1, 2) Then
        m = m + 1: brr(m, 2) = arr(i, 2) & Space(1) & "汇总"
        For j = 4 To UBound(arr, 2)
          brr(m, j) = total(j): total(j) = 0
        Next
      End If
      If arr(i, 1) <> arr(i + 1, 1) Then
        m = m + 1: brr(m, 1) = arr(i, 1) & Space(1) & "汇总"
        For j = 4 To UBound(arr, 2)
          brr(m, j) = crr(j): crr(j) = 0
        Next
      End If
    End If
  Next
  m = m + 1: brr(m, 1) = "总计"
  For i = 4 To UBound(arr, 2)
    brr(m, i) = drr(i)
  Next
  With Sheets("汇总").[a4]
    .Resize(Rows.Count - 3, UBound(brr, 2)).ClearContents
    .Resize(m, UBound(brr, 2)) = brr
  End With
End Sub

cqcbc

micch 发表于 2019-10-14 19:55
Excel自带的分类汇总，直接生成？？？？

谢谢提醒，我来用一下Excel自带的分类汇总。

cqcbc

wowo000 发表于 2019-10-14 20:05
帮你顶，期待哪位老师解决！

谢谢支持，看来有点儿难度。

cqcbc

一把小刀闯天下 发表于 2019-10-14 20:46
'凑了一个，看上去应该差不多，，，

Option Explicit

谢谢老师，完全正确，我来认真对比学习一下。

cqcbc

先把差异找出来，再认真学习、体会，谢谢老师。

micch

1. Sub test()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     r = Sheet1.[a65536].End(3).Row
   
4.     arr = Sheet1.Range("A1:E" & r)
   
5.     For i = 2 To UBound(arr)
   
6.         If Not d.exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
   
7.         If Not d(arr(i, 1)).exists(arr(i, 2)) Then Set d(arr(i, 1))(arr(i, 2)) = CreateObject("scripting.dictionary")
   
8.         For k = 3 To 5
   
9.             d(arr(i, 1))(arr(i, 2))(k) = d(arr(i, 1))(arr(i, 2))(k) + arr(i, k)
   
10.     Next k, i
    
11.     ReDim brr(1 To UBound(arr), 1 To 5)
    
12.     Dim br(3 To 5), cr(3 To 5)
    
13.     For Each a In d.keys
    
14.         For Each b In d(a).keys
    
15.             n = n + 1
    
16.             brr(n, 1) = a: brr(n, 2) = b
    
17.             For i = 3 To 5
    
18.                 brr(n, i) = d(a)(b)(i)
    
19.                 br(i) = br(i) + brr(n, i)
    
20.             Next
    
21.         Next
    
22.         n = n + 1:  brr(n, 1) = a: brr(n, 2) = "小计"
    
23.         For i = 3 To 5: brr(n, i) = br(i): cr(i) = cr(i) + br(i): Next
    
24.         Erase br
    
25.     Next
    
26.     n = n + 1:    brr(n, 2) = "总计"
    
27.     For i = 3 To 5: brr(n, i) = cr(i): Next
    
28.     With Sheet2
    
29.         .Range("a4:e" & n + 5).ClearContents
    
30.         .[a4].Resize(n, 5) = brr
    
31.     End With
    
32. End Sub
    

复制代码

练习字典

cqcbc

micch 发表于 2019-10-14 22:55
练习字典

同时也请老师将9楼的需求，解决一下，谢谢，也好让我跟着学习。