[已解决]根据统计客户统计业务量

Aкon

请大神帮忙，谢谢！

最佳答案

月排行榜 / 总排行榜

grf1973

2017-5-12 09:30

按要求只显示前48条。

1. Sub 生成()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheets(1).Range("a4:d" & Sheets(1).[c65536].End(3).Row)
   
4.     Dim brr(1 To 16, 1 To 11)
   
5.     For i = 1 To UBound(arr)
   
6.         x = arr(i, 3)
   
7.         If x <> "" Then d(x) = d(x) + arr(i, 4)
   
8.     Next
   
9.     For Each x In d.keys
   
10.         n = n + 1
    
11.         If n > 48 Then Exit For
    
12.         i = n Mod 16: If i = 0 Then i = 16
    
13.         k = Int((n - 0.1) / 16): j = 4 * k + 1
    
14.         brr(i, j) = n
    
15.         brr(i, j + 1) = x
    
16.         brr(i, j + 2) = d(x)
    
17.     Next
    
18.     [a2:k17] = ""
    
19.     [a2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
20. End Sub

复制代码

跳转到最佳答案楼层

QCW911

查查字典的例子，字典累加就可以解决

Aкon

QCW911 发表于 2017-5-12 08:04
查查字典的例子，字典累加就可以解决

不懂

qqyyh

看看 5.rar (14.97 KB, 下载次数: 4)

2017-5-12 09:14 上传

点击文件名下载附件

grf1973

按要求只显示前48条。

1. Sub 生成()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheets(1).Range("a4:d" & Sheets(1).[c65536].End(3).Row)
   
4.     Dim brr(1 To 16, 1 To 11)
   
5.     For i = 1 To UBound(arr)
   
6.         x = arr(i, 3)
   
7.         If x <> "" Then d(x) = d(x) + arr(i, 4)
   
8.     Next
   
9.     For Each x In d.keys
   
10.         n = n + 1
    
11.         If n > 48 Then Exit For
    
12.         i = n Mod 16: If i = 0 Then i = 16
    
13.         k = Int((n - 0.1) / 16): j = 4 * k + 1
    
14.         brr(i, j) = n
    
15.         brr(i, j + 1) = x
    
16.         brr(i, j + 2) = d(x)
    
17.     Next
    
18.     [a2:k17] = ""
    
19.     [a2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
20. End Sub

复制代码

Aкon

谢谢！太好了，终于解决了

Aкon

qqyyh 发表于 2017-5-12 09:14
看看

你的我怎么弄来弄去，弄出重复名字跟金额出来了，可能我没弄名白，总之谢谢你了

chart888

1. Private Sub CommandButton1_Click()
   
2. 
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. 
   
6. Dim ar
   
7. Dim r, i, r1, r2 As Integer
   
8. r = ThisWorkbook.Worksheets("1").Range("C65536").End(xlUp).Row
   
9. Set d = CreateObject("Scripting.Dictionary")
   
10.     ar = ThisWorkbook.Worksheets("1").Range("C4:D" & r)
    
11.     For i = 1 To UBound(ar)
    
12.         If ar(i, 1) <> "" Then d(ar(i, 1)) = d(ar(i, 1)) + ar(i, 2)
    
13.     Next
    
14.    
    
15. With ThisWorkbook.Worksheets("2")
    
16.     .Range("B2:C65536").ClearContents
    
17.     .Range("F2:G65536").ClearContents
    
18.     .Range("J2:K65536").ClearContents
    
19.     .Range("B2").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    
20.     If .Range("B18").Value <> "" Then
    
21.         r1 = .Range("B65536").End(xlUp).Row
    
22.         .Range("B18").Resize(r1 - 17, 2).Copy
    
23.         .Range("F2").PasteSpecial Paste:=xlPasteValues
    
24.         .Range("B18:C65536").ClearContents
    
25.     End If
    
26.         If .Range("F18").Value <> "" Then
    
27.             r2 = .Range("F65536").End(xlUp).Row
    
28.             .Range("F18").Resize(r12 - 17, 2).Copy
    
29.             .Range("J2").PasteSpecial Paste:=xlPasteValues
    
30.             .Range("F18:G65536").ClearContents
    
31.         End If
    
32. End With
    
33. 
    
34. Application.ScreenUpdating = True
    
35. Application.DisplayAlerts = True
    
36.    
    
37. End Sub
    

复制代码

Aкon

chart888 发表于 2017-5-12 11:17

不好意思这段时间出差忙去了，没上来看，才看到你帮我的答案，谢了哈