[已解决]多条件汇总（删除重复项和汇总为零的行）

昆山

实际工作中一份表有数千行（记录每天增减的数量），需要进行多条件汇总。
请高手帮忙用VBA帮忙解决。 库存宏表.zip (12.42 KB, 下载次数: 20)

2013-7-10 09:03 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

haiyangzhixin81

2013-7-10 10:59

1. Sub 汇总()
   
2. Dim d As Object, i%, j%, arr, brr, crr, row1&
   
3. Set d = CreateObject("scripting.dictionary")      
   
4. 
   
5. row1 = Sheet1.Range("b65536").End(3).Row      
   
6. j = 1
   
7. 
   
8. arr = Sheet1.Range("c2:g" & row1)
   
9. 
   
10. For i = 1 To UBound(arr)
    
11.       If Not d.exists(arr(i, 1) & "," & arr(i, 2)) Then   
    
12.              d.Add arr(i, 1) & "," & arr(i, 2), arr(i, 5)               
    
13.       Else
    
14.              d(arr(i, 1) & "," & arr(i, 2)) = d(arr(i, 1) & "," & arr(i, 2)) + arr(i, 5)
    
15.       End If
    
16. Next
    
17. 
    
18. brr = d.keys
    
19. crr = d.items
    
20. 
    
21. ReDim drr(1 To d.Count, 1 To 3)
    
22. 
    
23. For i = 0 To UBound(brr)
    
24.       If crr(i) <> 0 Then
    
25.           drr(j, 1) = Split(brr(i), ",")(0)
    
26.           drr(j, 2) = Split(brr(i), ",")(1)
    
27.           drr(j, 3) = crr(i)
    
28.           j = j + 1
    
29.      End If
    
30. Next
    
31. 
    
32. Sheet2.Range("a2").Resize(d.Count, 3) = drr
    
33. 
    
34. Set d = Nothing
    
35. 
    
36. End Sub
    

复制代码

跳转到最佳答案楼层

妞叫七七

你这个用数据透视表比较简单

昆山

妞叫七七 发表于 2013-7-10 09:33
你这个用数据透视表比较简单

没用过数据透视表呵。
不知数据透视表的运行速度如何，上万行的表。

haiyangzhixin81

1. Sub 汇总()
   
2. Dim d As Object, i%, j%, arr, brr, crr, row1&
   
3. Set d = CreateObject("scripting.dictionary")      
   
4. 
   
5. row1 = Sheet1.Range("b65536").End(3).Row      
   
6. j = 1
   
7. 
   
8. arr = Sheet1.Range("c2:g" & row1)
   
9. 
   
10. For i = 1 To UBound(arr)
    
11.       If Not d.exists(arr(i, 1) & "," & arr(i, 2)) Then   
    
12.              d.Add arr(i, 1) & "," & arr(i, 2), arr(i, 5)               
    
13.       Else
    
14.              d(arr(i, 1) & "," & arr(i, 2)) = d(arr(i, 1) & "," & arr(i, 2)) + arr(i, 5)
    
15.       End If
    
16. Next
    
17. 
    
18. brr = d.keys
    
19. crr = d.items
    
20. 
    
21. ReDim drr(1 To d.Count, 1 To 3)
    
22. 
    
23. For i = 0 To UBound(brr)
    
24.       If crr(i) <> 0 Then
    
25.           drr(j, 1) = Split(brr(i), ",")(0)
    
26.           drr(j, 2) = Split(brr(i), ",")(1)
    
27.           drr(j, 3) = crr(i)
    
28.           j = j + 1
    
29.      End If
    
30. Next
    
31. 
    
32. Sheet2.Range("a2").Resize(d.Count, 3) = drr
    
33. 
    
34. Set d = Nothing
    
35. 
    
36. End Sub
    

复制代码

昆山

谢谢4楼层主，试用很好。