用VBA对多个字段进行分类汇总

nmcfbgttyl

求助：用VBA按单位名称分类汇总后面所有字段（列）到此工作表的另一个区域（不能覆盖原有数据）或到另一工作表，不用数据透视表或其它方法，只能用VBA，谢谢。

求助-用VBA进行多字段分类汇总.rar (21.24 KB, 下载次数: 48)

2013-12-14 19:43 上传

点击文件名下载附件

jsxjd

select ... sum(...) group by ...

蓝桥玄霜

汇总的结果是怎么样的？

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, brr, d, i&, j&, k&, s&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Sheet1.Activate
   
6. arr = Range("a1").CurrentRegion
   
7. ReDim brr(1 To UBound(arr) - 3, 1 To UBound(arr, 2))
   
8. For i = 4 To UBound(arr)
   
9.     If Not d.exists(arr(i, 2)) Then
   
10.         s = s + 1: d(arr(i, 2)) = s
    
11.         brr(s, 1) = s
    
12.         For j = 2 To UBound(arr, 2)
    
13.             brr(s, j) = arr(i, j)
    
14.         Next
    
15.     Else
    
16.         For k = 3 To UBound(arr, 2)
    
17.             brr(d(arr(i, 2)), k) = brr(d(arr(i, 2)), k) + arr(i, k)
    
18.         Next
    
19.     End If
    
20. Next
    
21. Sheet2.Activate
    
22. Cells.ClearContents
    
23. Sheet1.[a1:p3].Copy [a1]
    
24. Range("a4").Resize(s, UBound(brr, 2)) = brr
    
25. End Sub
    

复制代码

dsmch

……………………

nmcfbgttyl

回  dsmch：
谢谢您！正是我想要的，能否帮解释一下，学习学习！

dsmch

1. Sub Macro1()
   
2. On Error Resume Next '纠错处理，忽略空值
   
3. Dim arr, brr, d, i&, j&, k&, s&
   
4. Set d = CreateObject("scripting.dictionary") '创建字典对象
   
5. Sheet1.Activate
   
6. arr = Range("a1").CurrentRegion '数组arr
   
7. ReDim brr(1 To UBound(arr) - 3, 1 To UBound(arr, 2)) '数组brr
   
8. For i = 4 To UBound(arr)
   
9.     '如单位名称不存在，加入字典,对应s值，并把列对应的值赋值数组brr
   
10.     If Not d.exists(arr(i, 2)) Then
    
11.         s = s + 1: d(arr(i, 2)) = s
    
12.         brr(s, 1) = s
    
13.         For j = 2 To UBound(arr, 2)
    
14.             brr(s, j) = arr(i, j)
    
15.         Next
    
16.     Else
    
17.     '如存在，找出对应的s值并累加
    
18.         For k = 3 To UBound(arr, 2)
    
19.             brr(d(arr(i, 2)), k) = brr(d(arr(i, 2)), k) + arr(i, k)
    
20.         Next
    
21.     End If
    
22. Next
    
23. Sheet2.Activate
    
24. Cells.ClearContents
    
25. Sheet1.[a1:p3].Copy [a1] '复制标题
    
26. Range("a4").Resize(s, UBound(brr, 2)) = brr '填充数据
    
27. End Sub
    

复制代码

nmcfbgttyl

谢谢，数组这一块我得好好学一下！

白蝙蝠

dsmch 发表于 2013-12-14 21:37

如果把相同序号，相同单位名称的一起汇总，怎么添加语句呀？（假设序号有重复的现象）

LMY123

白蝙蝠 发表于 2018-7-11 22:57
如果把相同序号，相同单位名称的一起汇总，怎么添加语句呀？（假设序号有重复的现象）

1. Sub 字典法_同薄单表_多条件多列分类汇总()
   
2. 'On Error Resume Next
   
3. Dim arr, brr, d, i&, j&, k&, s&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Sheet1.Activate
   
6. arr = Range("a1").CurrentRegion
   
7. ReDim brr(1 To UBound(arr) - 3, 1 To UBound(arr, 2))
   
8. For i = 4 To UBound(arr)
   
9.     ss = arr(i, 1) & arr(i, 2)
   
10.     If Not d.exists(ss) Then
    
11.         s = s + 1
    
12.         d(ss) = s
    
13.         brr(s, 1) = s
    
14.         For j = 2 To UBound(arr, 2)
    
15.             brr(s, j) = arr(i, j)
    
16.         Next
    
17.     Else
    
18.         For k = 3 To UBound(arr, 2)
    
19.             brr(d(ss), k) = brr(d(ss), k) + arr(i, k)
    
20.         Next
    
21.     End If
    
22. Next
    
23. Sheet2.Activate
    
24. Cells.Clear
    
25. Sheet1.[a1:p3].Copy [a1]
    
26. Range("a4").Resize(s, UBound(brr, 2)) = brr
    
27. End Sub

复制代码