复杂的多表汇总(难度有点大,做出来有分加哦)

蓝桥玄霜

1. Sub dbhz()
   
2. Dim Sht1 As Worksheet, Sht As Worksheet
   
3. Dim i&, Myr&, Myc%, Arr, Myr1&, Myc1%, Arr1
   
4. Dim r1, n&, col%, r2, r3, nn&, j&
   
5. Application.ScreenUpdating = False
   
6. Set Sht1 = Sheet1
   
7. Myr1 = [c65536].End(xlUp).Row
   
8. Myc1 = [iv4].End(xlToLeft).Column
   
9. Range(Cells(4, 4), Cells(Myr1, Myc1 - 1)).ClearContents
   
10. Arr1 = Range(Cells(4, 4), Cells(Myr1, Myc1 - 1))
    
11. For Each Sht In Sheets
    
12.     If Sht.Name <> Sht1.Name Then
    
13.         Sht.Activate
    
14.         Myr = [c65536].End(xlUp).Row
    
15.         Myc = [iv4].End(xlToLeft).Column
    
16.         Arr = Range(Cells(2, 1), Cells(Myr, Myc - 1))
    
17.         For i = 4 To Myc - 1
    
18.             nn = Cells(2, i).MergeArea.Columns.Count
    
19.             If nn > 1 Then
    
20.                 For j = i + 1 To i + nn - 1
    
21.                     Arr(1, j) = Cells(2, i)
    
22.                 Next
    
23.                 i = i + nn - 1
    
24.             End If
    
25.         Next
    
26.         Sht1.Activate
    
27.         For i = 3 To UBound(Arr)
    
28.             Set r1 = Sht1.[c:c].Find(Arr(i, 3), , , 1)
    
29.             n = r1.Row - 3
    
30.             For j = 4 To UBound(Arr, 2)
    
31.                 Set r2 = Sht1.Rows(2).Find(Arr(1, j), , , 1)
    
32.                 col = r2.Column
    
33.                 nn = Sht1.Cells(2, col).MergeArea.Columns.Count
    
34.                 If nn > 1 Then
    
35.                     With Sht1.Range(Cells(3, col), Cells(3, col + nn - 1))
    
36.                     Set r3 = .Find(Arr(2, j))
    
37.                     col = r3.Column
    
38.                     End With
    
39.                 Else
    
40.                 End If
    
41.                 Arr1(n, col - 3) = Arr1(n, col - 3) + Arr(i, j)
    
42.             Next
    
43.         Next
    
44.     End If
    
45. Next
    
46. [d4].Resize(UBound(Arr1), UBound(Arr1, 2)) = Arr1
    
47. Application.ScreenUpdating = True
    
48. End Sub
    

复制代码

[ 本帖最后由 彭希仁 于 2010-1-20 21:03 编辑 ]

alzeng

1. 
   
2. Sub DataSums()
   
3.     Dim Arr, Ary, k%, icol%
   
4.     Dim Sh As Worksheet, Str$
   
5.     Dim Dic As Object
   
6. 
   
7.     Set Dic = CreateObject("Scripting.Dictionary")
   
8.     Arr = Range("B2", [D65536].End(3).End(2).Offset(-1, -1))
   
9.     For k = 3 To UBound(Arr)
   
10.         If Arr(k, 1) = "" Then Arr(k, 1) = Arr(k - 1, 1)
    
11.     Next
    
12. 
    
13.     For icol = 3 To UBound(Application.Transpose(Arr))
    
14.         If Arr(1, icol) = "" Then Arr(1, icol) = Arr(1, icol - 1)
    
15.         If Left(Arr(1, icol), 1) Like "[A-Z]" Then Arr(1, icol) = Right(Arr(1, icol), Len(Arr(1, icol)) - 1)
    
16.     Next
    
17. 
    
18.     For Each Sh In Sheets
    
19.         If Sh.Name <> ActiveSheet.Name Then
    
20.             Ary = Sh.Range("B2", Sh.[D65536].End(3).End(2).Offset(-1, -1))
    
21.             For k = 3 To UBound(Ary)
    
22.                 If Ary(k, 1) = "" Then Ary(k, 1) = Ary(k - 1, 1)
    
23.             Next
    
24. 
    
25.             For icol = 3 To UBound(Application.Transpose(Ary))
    
26.                 If Ary(1, icol) = "" Then Ary(1, icol) = Ary(1, icol - 1)
    
27.                  If Left(Ary(1, icol), 1) Like "[A-Z]" Then Ary(1, icol) = Right(Ary(1, icol), Len(Ary(1, icol)) - 1)
    
28.             Next
    
29.             For k = 3 To UBound(Ary)
    
30.                 For icol = 3 To UBound(Application.Transpose(Ary))
    
31.                 Str = Ary(k, 1) & Ary(k, 2) & " " & Ary(1, icol) & Ary(2, icol)
    
32.                     Dic(Str) = Dic(Str) + Ary(k, icol)
    
33.                 Next
    
34.             Next
    
35.             Erase Ary
    
36.         End If
    
37.     Next
    
38.    
    
39.     Ary = Range("D4", [D65536].End(3).End(2).Offset(-1, -1))
    
40.     For k = 1 To UBound(Ary)
    
41.         For icol = 1 To UBound(Application.Transpose(Ary))
    
42.             Ary(k, icol) = Dic(Arr(k + 2, 1) & Arr(k + 2, 2) & " " & Arr(1, icol + 2) & Arr(2, icol + 2))
    
43.         Next
    
44.     Next
    
45.     Dic.RemoveAll
    
46. 
    
47.     [D4].Resize(k - 1, UBound(Application.Transpose(Ary))) = Ary
    
48. End Sub
    

复制代码

销量汇总01.rar (25.08 KB, 下载次数: 356)

2010-1-19 12:45 上传

点击文件名下载附件

[ 本帖最后由 alzeng 于 2010-1-19 12:45 编辑 ]

gjj136138139

不会字典嵌套，所以整了个特费事的出来。变通了一下儿。

[ 本帖最后由 gjj136138139 于 2010-1-19 22:09 编辑 ]

高度保密

结果好像有点不对，比如广东GZ02-V300黑色应该是4，广东GZ18-V300黑色应该是12，后边还有好多

alzeng

原帖由 高度保密 于 2010-1-19 11:57 发表
结果好像有点不对，比如广东GZ02-V300黑色应该是4，广东GZ18-V300黑色应该是12，后边还有好多

原代码少了加了个空格，致使结果异常，已修正。

彭希仁

呵呵引用了很多高手啊

彭希仁

原帖由 alzeng 于 2010-1-19 15:08 发表

原代码少了加了个空格，致使结果异常，已修正。

结果正确,速度快,如果适应更强一些就更完美了

ccwan

晚上拷回家做的

1. Const r = 4
   
2. Sub cc()
   
3. Dim i&, j&, k&, m&, n&, x&, rng, Arr, brr, Sh As Worksheet, d As Object
   
4. Application.ScreenUpdating = False
   
5. Range(Cells(2, 2), Cells(2, 100)).Replace "Z", "V"
   
6. rng = [b1].CurrentRegion
   
7. For i = r To UBound(rng) - 1
   
8. If rng(i, 1) = "" Then rng(i, 1) = rng(i - 1, 1)
   
9. Next
   
10. For i = r To UBound(rng, 2) - 1
    
11. If rng(2, i) = "" Then rng(2, i) = rng(2, i - 1)
    
12. Next
    
13. For Each Sh In ThisWorkbook.Sheets
    
14. If Sh.Name <> "总表" Then
    
15. t = 0
    
16. Set d = CreateObject("scripting.dictionary")
    
17. Arr = Sh.[b1].CurrentRegion
    
18. For i = r To UBound(Arr) - 1
    
19. If Arr(i, 1) = "" Then Arr(i, 1) = Arr(i - 1, 1)
    
20. Next
    
21. For i = r To UBound(Arr, 2)
    
22. If Arr(2, i - 1) = "" Then Arr(2, i - 1) = Arr(2, i - 2)
    
23. d(Arr(2, i - 1) & Arr(3, i - 1)) = ""
    
24. Next
    
25. n = 0
    
26. For k = r To UBound(rng, 2) - 1
    
27. m = 0
    
28. x = 0
    
29. y = 0
    
30. Do While t < UBound(rng, 2) - 2
    
31. j = j + 1
    
32. If d.exists(rng(2, t + 2) & rng(3, t + 2)) Then
    
33. If j = UBound(rng) - 3 Then m = 0: n = n + 1: GoTo 0
    
34. m = m + 1
    
35. If rng(r + m - 1, 1) & rng(r + m - 1, 2) = Arr(r + x, 1) & Arr(r + x, 2) Then
    
36. y = y + 1
    
37. If rng(2, t + 2) & rng(3, t + 2) = Arr(2, r + n - 1) & Arr(3, r + n - 1) Then
    
38. rng(m + 3, t + 2) = rng(m + 3, t + 2) + Arr(3 + y, r + n - 1)
    
39. 'Cells(m + 3, t + 3) = Cells(m + 3, t + 3) + Arr(3 + y, r + n - 1)
    
40. x = x + 1
    
41. End If
    
42. End If
    
43. Else
    
44. 0
    
45. t = t + 1
    
46. x = 0
    
47. j = 0
    
48. y = 0
    
49. End If
    
50. Loop
    
51. n = n + 1
    
52. If n = UBound(Arr, 2) Then n = 0
    
53. Next
    
54. End If
    
55. Set d = Nothing
    
56. Next
    
57. [b1].Resize(UBound(rng) - 1, UBound(rng, 2) - 1) = rng
    
58. Range(Cells(2, 2), Cells(2, 100)).Replace "V", "Z"
    
59. Application.ScreenUpdating = True
    
60. End Sub

复制代码

销量汇总end.rar (21.31 KB, 下载次数: 284)

2010-1-20 07:17 上传

点击文件名下载附件

高度保密

蓝桥的结果和直到清心的结果一模一样，不知版主为何得出两个结论。
销量汇总0119.rar (37.7 KB, 下载次数: 135)

2010-1-20 10:03 上传

点击文件名下载附件

lgcmeli

函数公式不能解决吗？问问。