[已解决]高难度的汇总，不知道有没有老师肯出手帮帮无助的我！！！

lenovo0312

高难度的汇总，不知道有没有老师能出手帮帮无助的我！！！



高难度汇总Book1.rar (7.5 KB, 下载次数: 12)

2012-10-27 17:31 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

tomle

2012-10-27 22:45

1. Sub 兰版的下棋法()
   
2. Dim arr, arr1(1 To 1000, 1 To 8), arr2, sr
   
3. Dim x, y, k, d, hk, rn As Range
   
4. arr2 = Array("编码", "产地", "货品", "规格", "方式", "单价", "听数", "金额")
   
5. arr = Range("c5:t17")
   
6. Set d = CreateObject("scripting.dictionary")
   
7. For x = 1 To UBound(arr)
   
8. sr = arr(x, 2) & arr(x, 7)
   
9. If d.exists(sr) Then
   
10. hk = d(sr)
    
11. arr1(hk, 7) = arr1(hk, 7) + arr(x, 16)
    
12. arr1(hk, 8) = arr1(hk, 8) + arr(x, 9)
    
13. Else
    
14. k = k + 1
    
15. d(sr) = k
    
16. arr1(k, 1) = arr(x, 18)
    
17. arr1(k, 2) = arr(x, 1)
    
18. arr1(k, 3) = arr(x, 2)
    
19. arr1(k, 4) = arr(x, 3)
    
20. arr1(k, 5) = arr(x, 4)
    
21. arr1(k, 6) = arr(x, 7)
    
22. arr1(k, 7) = arr(x, 16)
    
23. arr1(k, 8) = arr(x, 9)
    
24. End If
    
25. Next x
    
26. Sheets.Add before:=Sheets(1)
    
27. With ActiveSheet
    
28. .Name = "数据汇总表" & Sheets.Count
    
29. .Cells(1, 1).Resize(1, 8) = arr2
    
30. .Cells(2, "a").Resize(UBound(arr1), 8) = arr1
    
31. For Each rn In .Range("c2:c" & UBound(arr1) + 1)
    
32. If Application.WorksheetFunction.CountIf(.Range("c2:c" & UBound(arr1) + 1), rn) = 1 Then rn.EntireRow.Delete
    
33. Next
    
34. End With
    
35. End Sub
    
36. 
    

复制代码

仅供参考，向兰版致敬

跳转到最佳答案楼层

cliyu

tomle

1. Sub 兰版的下棋法()
   
2. Dim arr, arr1(1 To 1000, 1 To 8), arr2, sr
   
3. Dim x, y, k, d, hk, rn As Range
   
4. arr2 = Array("编码", "产地", "货品", "规格", "方式", "单价", "听数", "金额")
   
5. arr = Range("c5:t17")
   
6. Set d = CreateObject("scripting.dictionary")
   
7. For x = 1 To UBound(arr)
   
8. sr = arr(x, 2) & arr(x, 7)
   
9. If d.exists(sr) Then
   
10. hk = d(sr)
    
11. arr1(hk, 7) = arr1(hk, 7) + arr(x, 16)
    
12. arr1(hk, 8) = arr1(hk, 8) + arr(x, 9)
    
13. Else
    
14. k = k + 1
    
15. d(sr) = k
    
16. arr1(k, 1) = arr(x, 18)
    
17. arr1(k, 2) = arr(x, 1)
    
18. arr1(k, 3) = arr(x, 2)
    
19. arr1(k, 4) = arr(x, 3)
    
20. arr1(k, 5) = arr(x, 4)
    
21. arr1(k, 6) = arr(x, 7)
    
22. arr1(k, 7) = arr(x, 16)
    
23. arr1(k, 8) = arr(x, 9)
    
24. End If
    
25. Next x
    
26. Sheets.Add before:=Sheets(1)
    
27. With ActiveSheet
    
28. .Name = "数据汇总表" & Sheets.Count
    
29. .Cells(1, 1).Resize(1, 8) = arr2
    
30. .Cells(2, "a").Resize(UBound(arr1), 8) = arr1
    
31. For Each rn In .Range("c2:c" & UBound(arr1) + 1)
    
32. If Application.WorksheetFunction.CountIf(.Range("c2:c" & UBound(arr1) + 1), rn) = 1 Then rn.EntireRow.Delete
    
33. Next
    
34. End With
    
35. End Sub
    
36. 
    

复制代码

仅供参考，向兰版致敬