多表数据汇总，谢谢！

蓝桥玄霜

请见附件。

Albert128

蓝桥玄霜 发表于 2012-8-26 19:25
请见附件。

蓝版,您把字典用得出神入化,学生佩服之极!
有个小问题：1、最后一行"合计"并非以上所有数据的汇总,请改为其他项目一样合并而得；
                     2、002至003、002至002点合并时，合计上有两行空白。
另：能否把上次向您请教的特殊排序,融入到此，那此表就完善了。
http://club.excelhome.net/thread-908794-1-1.html

蓝桥玄霜

什么是“其他项目一样合并而得”？

Albert128

蓝桥玄霜 发表于 2012-8-26 20:48
什么是“其他项目一样合并而得”？

就像其他会计科目一样，比如：“库存现金”是三表之和，三表合并后的“合计”等于三个表“合计”之和

蓝桥玄霜

是的，把特殊排序的代码配进去应该是可以解决排序的问题了。

Albert128

蓝桥玄霜 发表于 2012-8-26 21:05
是的，把特殊排序的代码配进去应该是可以解决排序的问题了。

蓝版，实在太麻烦您了。
能不能帮我把附件里代码优化一下,今天想了一天,对字典用法是挺模糊的，走一些弯路。

蓝桥玄霜

1. Sub 宏1()
   
2.     Dim arr, brr(1 To 100000, 1 To 3), i&, j&, m&, t, d As Object, sh As Worksheet
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Range("A2:c2").Select
   
6.     Range(Selection, Selection.End(xlDown)).Select
   
7.     Selection.ClearContents
   
8.     For Each sh In Worksheets
   
9.         If sh.Name <> "汇总" Then
   
10.             arr = sh.[c1].CurrentRegion
    
11.             For i = 2 To UBound(arr)
    
12.                 t = d(arr(i, 3))
    
13.                 If t = "" Then
    
14.                     m = m + 1
    
15.                     d(arr(i, 3)) = m
    
16.                     brr(m, 1) = arr(i, 3)
    
17.                     brr(m, 2) = arr(i, 10)
    
18.                     brr(m, 3) = arr(i, 11)
    
19.                 Else
    
20.                     brr(t, 2) = brr(t, 2) + arr(i, 10)
    
21.                     brr(t, 3) = brr(t, 3) + arr(i, 11)
    
22.                 End If
    
23.             Next
    
24.         End If
    
25.     Next
    
26.     Range("A2").Resize(m, 3) = brr
    
27.     Range("A1").Select
    
28.     Application.ScreenUpdating = True
    
29. End Sub
    
30. 
    

复制代码

蓝桥玄霜

请见附件。

蓝桥玄霜

带特殊排序的完整版。

1. Sub lqxs_px()
   
2. Dim Arr, i&, j&, aa, n&, m&
   
3. Dim d, k, t, k1, t1, km$, Brr
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set d1 = CreateObject("Scripting.Dictionary")
   
6. Sheet3.Activate
   
7. Arr = [a1].CurrentRegion
   
8. [a2:c500].ClearContents
   
9. For i = 2 To UBound(Arr)
   
10.     km = Left(Arr(i, 1), 4)
    
11.     If Mid(Arr(i, 1), 5, 1) <> "[" Then
    
12.         d(km) = Arr(i, 1) & "," & Arr(i, 2) & "," & Arr(i, 3)
    
13.     Else
    
14.         d1(km) = d1(km) & i & ","
    
15.     End If
    
16. Next
    
17. k = d.Keys: k1 = d1.Keys
    
18. t = d1.Items: t1 = d.Items: n = 1
    
19. [p1].Resize(d.Count) = Application.Transpose(k)
    
20. [q1].Resize(d.Count) = Application.Transpose(t1)
    
21. [p1].Resize(d.Count, 2).Sort [p1], 1
    
22. Brr = [p1].CurrentRegion
    
23. 
    
24. For i = 1 To UBound(Brr)
    
25.     n = n + 1: m = 0
    
26.     [p:q].ClearContents
    
27.     Cells(n, 1) = Brr(i, 2)
    
28.     If d1.Exists(CStr(Brr(i, 1))) Then
    
29.         tt = d1(CStr(Brr(i, 1)))
    
30.         tt = Left(tt, Len(tt) - 1)
    
31.         If InStr(tt, ",") Then
    
32.             aa = Split(tt, ",")
    
33.             For j = 0 To UBound(aa)
    
34.                 m = m + 1
    
35.                 Cells(m, 16) = Arr(aa(j), 1) & "," & Arr(aa(j), 2) & "," & Arr(aa(j), 3)
    
36.             Next
    
37.             [p1].Resize(m, 1).Sort [p1], 1
    
38.             [p1].Resize(m, 1).Copy Cells(n + 1, 1)
    
39.             n = n + m
    
40.         Else
    
41.             n = n + 1
    
42.             Cells(n, 1) = Arr(tt, 1) & "," & Arr(tt, 2) & "," & Arr(tt, 3)
    
43.         End If
    
44.     End If
    
45. Next
    
46.     [p:p].ClearContents
    
47. Application.DisplayAlerts = False
    
48. [a2].Resize(UBound(Arr)).TextToColumns Comma:=True
    
49. Application.DisplayAlerts = True
    
50. End Sub
    

复制代码

蓝桥玄霜

请见附件。