多字段分类汇总问题

Laughingsun889

老师们，下午好！多字段分类汇总用VBA如何处理？具体说明和要求在附件的想要的结果表中！谢谢！

tel3033

1. Sub byDD()
   
2.     Dim i%, j%, n%, s$, arr, brr(), d(1 To 5) As Object
   
3.     On Error Resume Next
   
4.     For i = 1 To 5
   
5.     Set d(i) = CreateObject("Scripting.Dictionary")
   
6.     Next
   
7. With Sheet1
   
8.     arr = .[a1].CurrentRegion
   
9.     For i = 2 To UBound(arr)
   
10.         For j = 1 To 5
    
11.         d(j)(Format(arr(i, 1), "yyyy")) = d(j)(Format(arr(i, 1), "yyyy")) + arr(i, j + 2)
    
12.         d(j)(Format(arr(i, 1), "m")) = d(j)(Format(arr(i, 1), "m")) + arr(i, j + 2)
    
13.         d(j)(Format(arr(i, 1), "m") & arr(i, 2)) = d(j)(Format(arr(i, 1), "m") & arr(i, 2)) + arr(i, j + 2)
    
14.         t = d(j).items()(0)
    
15.         Next j
    
16.         endrow = endrow + 1
    
17.         ReDim Preserve brr(1 To 7, 1 To endrow)
    
18.         For n = 1 To 7
    
19.             brr(n, endrow) = arr(i, n)
    
20.         Next n
    
21.         If Format(arr(i + 1, 1), "m") & arr(i + 1, 2) <> Format(arr(i, 1), "m") & arr(i, 2) Then
    
22.             endrow = endrow + 1: s = Format(arr(i, 1), "m") & arr(i, 2)
    
23.             ReDim Preserve brr(1 To 7, 1 To endrow)
    
24.             For n = 1 To 7
    
25.                 brr(n, endrow) = Array("", "小计", d(1)(s), d(2)(s), d(3)(s), d(4)(s), d(5)(s))(n - 1)
    
26.             Next n
    
27.             .Range("b" & endrow + 1 & ":g" & endrow + 1).Interior.Color = 65535
    
28.         End If
    
29.         If Format(arr(i + 1, 1), "m") <> Format(arr(i, 1), "m") Then
    
30.             endrow = endrow + 1: s = Format(arr(i, 1), "m")
    
31.             ReDim Preserve brr(1 To 7, 1 To endrow)
    
32.             For n = 1 To 7
    
33.                 brr(n, endrow) = Array("", "合计", d(1)(s), d(2)(s), d(3)(s), d(4)(s), d(5)(s))(n - 1)
    
34.             Next n
    
35.             .Range("b" & endrow + 1 & ":g" & endrow + 1).Interior.Color = 5296274
    
36.         End If
    
37.     Next i
    
38.         endrow = endrow + 1: s = (Format(arr(i-1, 1), "yyyy"))
    
39.         ReDim Preserve brr(1 To 7, 1 To endrow)
    
40.         For n = 1 To 7
    
41.             brr(n, endrow) = Array("", "总计", d(1)(s), d(2)(s), d(3)(s), d(4)(s), d(5)(s))(n - 1)
    
42.         Next n
    
43.     .Range("b" & endrow + 1 & ":g" & endrow + 1).Interior.Color = 15773696
    
44.     .[a2].Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
    
45.     .Range("a1:g" & .Cells(Rows.Count, 2).End(xlUp).Row).Borders.LineStyle = xlContinuous
    
46. End With
    
47. End Sub

复制代码

tel3033

..........

鄂龙蒙

分工艺自动小计合计.rar (17.24 KB, 下载次数: 30)

2022-6-7 16:07 上传

点击文件名下载附件

wowo000

tel3033 发表于 2022-6-7 15:37
..........

你好！tel3033老兄。如果把容错语句“On Error Resume Next”去掉会提示下标越界，可否修正？？

tel3033

wowo000 发表于 2022-6-7 16:08
你好！tel3033老兄。如果把容错语句“On Error Resume Next”去掉会提示下标越界，可否修正？？

学艺不精，不知道怎么修正才加了个容错。

wowo000

鄂龙蒙 发表于 2022-6-7 16:07

鄂龙蒙老师：你好！俺改成这样，接下咋改？可否指教？？

鄂龙蒙

wowo000 发表于 2022-6-7 16:33
鄂龙蒙老师：你好！俺改成这样，接下咋改？可否指教？？

给您的附件不能用？

wowo000

鄂龙蒙 发表于 2022-6-7 17:00
给您的附件不能用？

您的附件没问题。只不过没完全符合楼主的要求。可否改进？？

wxxydl

我给你做了一个  看一下是这样的吗