[已解决]如何用vba快速进行排序并进行统计？

kangkangtianxia

想要的结果是：对左边的数据进行排序并进行统计，以“产生单位”、“类别”、“名称”、“接收单位”为关键字，如果这四个关键字都一样的话，就对其对应的数量进行汇总统计，其中一个不相同的话就单独统计。模拟的结果见sheet“目标结果”。谢谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2015-2-4 12:58

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, s&, zf$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To 6)
   
6. For i = 2 To UBound(arr)
   
7.     zf = arr(i, 2) & "," & arr(i, 5) & "," & arr(i, 6) & "," & arr(i, 8)
   
8.     If Not d.exists(zf) Then
   
9.         s = s + 1
   
10.         d(zf) = s
    
11.         brr(s, 1) = arr(i, 2)
    
12.         brr(s, 2) = arr(i, 5)
    
13.         brr(s, 3) = arr(i, 6)
    
14.         brr(s, 4) = arr(i, 7)
    
15.         brr(s, 5) = arr(i, 8)
    
16.         brr(s, 6) = arr(i, 1)
    
17.     Else
    
18.         n = d(zf)
    
19.         brr(n, 4) = brr(n, 4) + arr(i, 7)
    
20.     End If
    
21. Next
    
22. Sheet2.Range("a2").Resize(s, 6) = brr
    
23. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, s&, zf$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To 6)
   
6. For i = 2 To UBound(arr)
   
7.     zf = arr(i, 2) & "," & arr(i, 5) & "," & arr(i, 6) & "," & arr(i, 8)
   
8.     If Not d.exists(zf) Then
   
9.         s = s + 1
   
10.         d(zf) = s
    
11.         brr(s, 1) = arr(i, 2)
    
12.         brr(s, 2) = arr(i, 5)
    
13.         brr(s, 3) = arr(i, 6)
    
14.         brr(s, 4) = arr(i, 7)
    
15.         brr(s, 5) = arr(i, 8)
    
16.         brr(s, 6) = arr(i, 1)
    
17.     Else
    
18.         n = d(zf)
    
19.         brr(n, 4) = brr(n, 4) + arr(i, 7)
    
20.     End If
    
21. Next
    
22. Sheet2.Range("a2").Resize(s, 6) = brr
    
23. End Sub

复制代码

dsmch

………………

kangkangtianxia

dsmch 发表于 2015-2-4 13:05
………………

谢谢！还有个问题就是能否利用“数据源”的数据一次性得到以下这个结果呢？？见附图。。谢谢！！

kangkangtianxia

dsmch 发表于 2015-2-4 13:05
………………

如果是这个结果呢？就是加多一列，对“产生单位”的数量进行合计。。该怎么处理呢？、谢谢！见附件。。

kangkangtianxia

kangkangtianxia 发表于 2015-2-4 16:01
如果是这个结果呢？就是加多一列，对“产生单位”的数量进行合计。。该怎么处理呢？、谢谢！见附件。。

那该怎么操作呢？？请指教！

grf1973

在dsmch老师后面加一段即可

1. Sub Macro1()
   
2.     Dim arr, brr, d, i&, s&, zf$
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.Range("a1").CurrentRegion
   
5.     ReDim brr(1 To UBound(arr), 1 To 6)
   
6.     For i = 2 To UBound(arr)
   
7.         zf = arr(i, 2) & "," & arr(i, 5) & "," & arr(i, 6) & "," & arr(i, 8)
   
8.         If Not d.exists(zf) Then
   
9.             s = s + 1
   
10.             d(zf) = s
    
11.             brr(s, 1) = arr(i, 2)
    
12.             brr(s, 2) = arr(i, 5)
    
13.             brr(s, 3) = arr(i, 6)
    
14.             brr(s, 4) = arr(i, 7)
    
15.             brr(s, 5) = arr(i, 8)
    
16.             brr(s, 6) = arr(i, 1)
    
17.         Else
    
18.             n = d(zf)
    
19.             brr(n, 4) = brr(n, 4) + arr(i, 7)
    
20.         End If
    
21.     Next
    
22.     With Sheet2
    
23.         .Range("a2:g1000").Clear
    
24.         .Range("a2").Resize(s, 6) = brr
    
25.         .Range("a2").Resize(s, 6).Sort key1:=.[a2]
    
26.         arr = .[a1].CurrentRegion
    
27.         For i = 2 To UBound(arr)
    
28.             arr(i, 7) = arr(i, 4)
    
29.             If arr(i, 1) = arr(i - 1, 1) Then
    
30.                 .Cells(i - 1, 7).Resize(2, 1).Merge
    
31.                 arr(i - 1, 7) = Application.WorksheetFunction.SumIf(.[a2].Resize(s, 1), arr(i, 1), .[d2].Resize(s, 1))
    
32.             End If
    
33.         Next
    
34.         .[a1].CurrentRegion = arr
    
35.     End With
    
36. End Sub

复制代码

kangkangtianxia

grf1973 发表于 2015-2-5 11:13
在dsmch老师后面加一段即可

谢谢解答。。谢谢！