分类汇总总增加一列

fansch

各位老师，
我想分类汇总一个表，源文件表的分类项不一定在一起的且有空白的单元格，空白单元格的行不参与分类汇总，
在分类汇总的时候，新增一列将分类的字段填入到新增列中，另外，未参与分类那行的名称自动移动到新增列中。
最后，是否还可以实现将表格恢复到汇总之前的样子。
先谢谢各位了。

半百

1. Sub test()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. With Sheets("测试数据")
   
4.     r = .Cells(Rows.Count, 1).End(3).Row
   
5.     arr = .Range("a4:h" & r)
   
6. End With
   
7. For i = 1 To UBound(arr)
   
8.     If arr(i, 8) <> "" Then
   
9.         d(arr(i, 8)) = d(arr(i, 8)) & "," & i
   
10.     Else
    
11.         s = s & "," & i
    
12.     End If
    
13. Next
    
14. ReDim brr(1 To UBound(arr) * 2, 1 To 9)
    
15. For Each k In d.keys
    
16.     a = Split(d(k), ",")
    
17.     n = n + 1
    
18.     r = n
    
19.     m = m + 1
    
20.     brr(n, 1) = m
    
21.     brr(n, 2) = k
    
22.     For i = 1 To UBound(a)
    
23.         n = n + 1
    
24.         For j = 3 To 9
    
25.             brr(n, j) = arr(a(i), j - 1)
    
26.         Next
    
27.         brr(r, 6) = brr(r, 6) + brr(n, 6)
    
28.     Next
    
29.     d(k) = Array(r + 4, n - r)
    
30. Next
    
31. b = Split(s, ",")
    
32. For i = 1 To UBound(b)
    
33.     n = n + 1
    
34.     m = m + 1
    
35.     brr(n, 1) = m
    
36.     brr(n, 2) = arr(b(i), 2)
    
37.     For j = 4 To 8
    
38.         brr(n, j) = arr(b(i), j - 1)
    
39.     Next
    
40. Next
    
41. With Sheets("行成效果")
    
42.     .[a4].Resize(n, 9) = brr
    
43.     .[a4].Resize(n, 9).Borders.LineStyle = 1
    
44.     c = d.items
    
45.     For i = 0 To UBound(c)
    
46.          .Rows(c(i)(0)).Resize(c(i)(1)).Rows.Group
    
47.     Next
    
48. End With
    
49. End Sub
    

复制代码

ykcbf1100

插入一列，插入小计

ykcbf1100

参与一下。。。。

1. Sub ykcbf()  '//2024.4.10
   
2.     Application.ScreenUpdating = False
   
3.     With Sheets("测试数据")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[a1].Resize(r, 8)
   
6.     End With
   
7.     ReDim brr(1 To UBound(arr) * 3, 1 To 9)
   
8.     On Error Resume Next
   
9.     For i = 4 To UBound(arr)
   
10.         m = m + 1
    
11.         brr(m, 1) = arr(i, 1)
    
12.         For j = 2 To UBound(arr, 2)
    
13.             brr(m, j + 1) = arr(i, j)
    
14.         Next
    
15.     Next
    
16.     With Sheets("行成效果")
    
17.         .Cells.Interior.ColorIndex = 0
    
18.         .UsedRange.Offset(3).Clear
    
19.         .Columns(8).NumberFormatLocal = "0.00%"
    
20.         With .[a4].Resize(m, 9)
    
21.             .Value = brr
    
22.             .Borders.LineStyle = 1
    
23.             .HorizontalAlignment = xlCenter
    
24.             .VerticalAlignment = xlCenter
    
25.         End With
    
26.         .[b4].Resize(m, 8).Sort .[i4], 1
    
27.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
28.         For i = r To 4 Step -1
    
29.             x = r
    
30.             If .Cells(i, 9) <> .Cells(i - 1, 9) Then
    
31.                 m = i
    
32.                 .Rows(m).Insert
    
33.                 .Cells(m, 2) = .Cells(m + 1, 9)
    
34.                 .Cells(m, 6).FormulaR1C1 = "=SUM(R" & m + 1 & "C:R" & x + 1 & "C)"
    
35.                 With .Cells(m, 1).Resize(1, 9)
    
36.                     .Interior.ColorIndex = 6
    
37.                 End With
    
38.                 r = i - 1
    
39.             End If
    
40.         Next
    
41.     End With
    
42.     Application.ScreenUpdating = True
    
43.     MsgBox "OK！"
    
44. End Sub
    
45. 
    

复制代码

fansch

ykcbf1100 发表于 2024-4-10 14:38
参与一下。。。。

谢谢大师， 但是有个问题就是 空白单元格 是不需要参与分类汇总的，但是他的名称 要放到名称那列去，看看好不好改

ykcbf1100

fansch 发表于 2024-4-10 15:20
谢谢大师， 但是有个问题就是 空白单元格 是不需要参与分类汇总的，但是他的名称 要放到名称那列去，看 ...

改好了。。。

fansch

ykcbf1100 发表于 2024-4-10 15:23
改好了。。。

大师辛苦了，但是不存于分类的那些数据 要放到B列中。 还请辛苦 看一下，谢谢

ykcbf1100

fansch 发表于 2024-4-10 15:35
大师辛苦了，但是不存于分类的那些数据 要放到B列中。 还请辛苦 看一下，谢谢

再改一次。

ykcbf1100

最终代码如下：

1. Sub ykcbf()  '//2024.4.10
   
2.     Application.ScreenUpdating = False
   
3.     With Sheets("测试数据")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[a1].Resize(r, 8)
   
6.     End With
   
7.     ReDim brr(1 To UBound(arr) * 3, 1 To 9)
   
8.     On Error Resume Next
   
9.     For i = 4 To UBound(arr)
   
10.         m = m + 1
    
11.         brr(m, 1) = arr(i, 1)
    
12.         For j = 2 To UBound(arr, 2)
    
13.             brr(m, j + 1) = arr(i, j)
    
14.         Next
    
15.     Next
    
16.     With Sheets("行成效果")
    
17.         .Cells.Interior.ColorIndex = 0
    
18.         .UsedRange.Offset(3).Clear
    
19.         .Columns(8).NumberFormatLocal = "0.00%"
    
20.         With .[a4].Resize(m, 9)
    
21.             .Value = brr
    
22.             .Borders.LineStyle = 1
    
23.             .HorizontalAlignment = xlCenter
    
24.             .VerticalAlignment = xlCenter
    
25.         End With
    
26.         .[b4].Resize(m, 8).Sort .[i4], 1
    
27.         r = .Cells(.Rows.Count, 9).End(xlUp).Row
    
28.         For i = r To 4 Step -1
    
29.             x = r
    
30.             If .Cells(i, 9) <> .Cells(i - 1, 9) Then
    
31.                 m = i
    
32.                 .Rows(m).Insert
    
33.                 .Cells(m, 2) = .Cells(m + 1, 9)
    
34.                 .Cells(m, 6).FormulaR1C1 = "=SUM(R" & m + 1 & "C:R" & x + 1 & "C)"
    
35.                 With .Cells(m, 1).Resize(1, 9)
    
36.                     .Interior.ColorIndex = 6
    
37.                 End With
    
38.                 r = i - 1
    
39.             End If
    
40.         Next
    
41.         r1 = .Cells(Rows.Count, 9).End(3).Row
    
42.         r2 = .Cells(Rows.Count, 1).End(3).Row
    
43.         For i = r1 + 1 To r2
    
44.             .Cells(i, 2) = .Cells(i, 3)
    
45.             .Cells(i, 3) = ""
    
46.         Next
    
47.     End With
    
48.     Application.ScreenUpdating = True
    
49.     MsgBox "OK！"
    
50. End Sub
    

复制代码

fansch

ykcbf1100 发表于 2024-4-10 15:43
最终代码如下：

谢谢了，老师