[已解决]旧帖新要求

sparkguo

昨天发了一个帖子，谢谢各位大神的帮助；
先依据实际情况增加了需求，麻烦各位大侠帮忙。
详细信息见附件。

最佳答案

月排行榜 / 总排行榜

zjdh

2013-4-13 14:42

1. Sub test()
   
2.     Dim arr, brr
   
3.     Dim x%, k%
   
4.     Dim z As String
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Range("A4:F" & [A65536].End(3).Row)
   
7.     ReDim brr(1 To UBound(arr), 1 To 6)
   
8.     For x = 1 To UBound(arr)
   
9.         z = arr(x, 1) & arr(x, 2) & arr(x, 3) & arr(x, 4) & arr(x, 6)
   
10.         If d.exists(z) Then
    
11.                 brr(d(z), 5) = arr(x, 5) + brr(d(z), 5)
    
12.         Else
    
13.             k = k + 1
    
14.             d(z) = k
    
15.             For y = 1 To 6
    
16.                 brr(k, y) = arr(x, y)
    
17.             Next y
    
18.         End If
    
19.     Next x
    
20.     [H6].Resize(k, 6) = brr
    
21. End Sub
    
22. 
    

复制代码

跳转到最佳答案楼层

zjdh

1. Sub test()
   
2.     Dim arr, brr
   
3.     Dim x%, k%
   
4.     Dim z As String
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Range("A4:F" & [A65536].End(3).Row)
   
7.     ReDim brr(1 To UBound(arr), 1 To 6)
   
8.     For x = 1 To UBound(arr)
   
9.         z = arr(x, 1) & arr(x, 2) & arr(x, 3) & arr(x, 4) & arr(x, 6)
   
10.         If d.exists(z) Then
    
11.                 brr(d(z), 5) = arr(x, 5) + brr(d(z), 5)
    
12.         Else
    
13.             k = k + 1
    
14.             d(z) = k
    
15.             For y = 1 To 6
    
16.                 brr(k, y) = arr(x, y)
    
17.             Next y
    
18.         End If
    
19.     Next x
    
20.     [H6].Resize(k, 6) = brr
    
21. End Sub
    
22. 
    

复制代码