菜鸟求帮忙解决下多工作簿多工作表指定列内容用字典汇总

sha104

本人菜鸟，才接触字典不久，看了前面蓝版主的字典教程，也想试试，可是我自己按照教程始终无法得到我想要的结果，求大神帮忙写代码，我对比看看自己问题在哪。
附件里工作簿以及工作表样式都是一样的，这里先谢过了

蓝桥玄霜

1. Sub lqxs()
   
2.     Dim Arr, myPath$, myName$
   
3.     Dim funm$, i&, d
   
4.     Application.ScreenUpdating = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set wb = ThisWorkbook
   
7.     funm = "汇总.xlsm"
   
8.     Sheet1.Activate
   
9.     myPath = ThisWorkbook.Path & ""
   
10.     myName = Dir(myPath & "*.xlsx")
    
11.     Do While myName <> "" And myName <> funm
    
12.         With GetObject(myPath & myName)
    
13.             Arr = .Sheets(1).Range("b5").CurrentRegion
    
14.             .Close False
    
15.         End With
    
16.         For i = 1 To UBound(Arr)
    
17.             d(Arr(i, 1)) = ""
    
18.         Next
    
19.         myName = Dir
    
20.     Loop
    
21.     [b5].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
22.     Application.ScreenUpdating = True
    
23. End Sub
    

复制代码

蓝桥玄霜

请见附件。

sha104

版主大大动作就是快，万分感谢不过还有点小问题，每个工作簿还有其它2张表，能否点一下按钮，让其它工作簿的另外2张表内容也能汇总到“汇总”工作簿的同名工作表下？

sha104

蓝桥玄霜 发表于 2012-10-27 10:44

大大你只给了1个工作表内容的汇总，能不能同时把其他表的内容分别对应汇总到同名工作表下？

蓝桥玄霜

1. Sub lqxs()
   
2.     Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet
   
3.     Dim funm$, i&, d(2), nm, m&
   
4.     Application.ScreenUpdating = False
   
5.     For i = 0 To 2
   
6.         Set d(i) = CreateObject("Scripting.Dictionary")
   
7.     Next
   
8.     Set wb = ThisWorkbook
   
9.     funm = "汇总.xlsm"
   
10.     nm = Array("大班", "中班", "小班")
    
11.     myPath = ThisWorkbook.Path & ""
    
12.     myName = Dir(myPath & "*.xlsx")
    
13.     Do While myName <> "" And myName <> funm
    
14.         With GetObject(myPath & myName)
    
15.             For Each sh In .Sheets
    
16.                 Arr = sh.Range("b5").CurrentRegion
    
17.                 m = Application.Match(sh.Name, nm, 0) - 1
    
18.                 For i = 1 To UBound(Arr)
    
19.                     d(m)(Arr(i, 1)) = ""
    
20.                 Next
    
21.             Next
    
22.             .Close False
    
23.         End With
    
24.         myName = Dir
    
25.     Loop
    
26.     For i = 0 To 2
    
27.         Sheets(nm(i)).[b5].Resize(100, 1).ClearContents
    
28.         Sheets(nm(i)).[b5].Resize(d(i).Count, 1) = Application.Transpose(d(i).keys)
    
29.     Next
    
30.     Application.ScreenUpdating = True
    
31. End Sub
    

复制代码

蓝桥玄霜

请见附件。

sha104

蓝桥玄霜 发表于 2012-10-27 13:35

万分感谢，我这就去测试下！之前一直出问题的原因，经过几天的努力总算找到了：07版和03版vba代码不完全兼容啊。。。。。

东来东往

向蓝版学习了