求助多工作簿多工作表按工作表名称汇总

奥巴马学VBA

各位请帮忙看一下这种汇总应该如何用VBA，谢谢我把要求已经写在压缩包的文件了。。每个星期都要做的事。。好痛苦呀。请各位帮忙写一段代码汇总。。救救这所谓的“美国总统”吧。。。。。{:soso_e109:}



求助.rar (74.67 KB, 下载次数: 144)

2012-2-21 09:32 上传

点击文件名下载附件

skyzxh

应该可以做. q422714303

蓝桥玄霜

你的2003版本的汇总表能汇总2007版本的工作簿吗？
建议版本要统一。

蓝桥玄霜

1. Public Arr1(), r%, strTmp$, nm$
   
2. Function GetFileFolderList(ObjFolder) As String
   
3.     Dim SubFolders, SubFolder, hz$
   
4.     Dim Files, File
   
5.     hz = "xls"  '指定后缀
   
6.     Set Files = ObjFolder.Files
   
7.     If Files.Count <> 0 Then
   
8.         For Each File In Files
   
9.             If Right(File, 3) = hz Then
   
10.                 r = r + 1
    
11.                 ReDim Preserve Arr1(1 To r)
    
12.                 Arr1(r) = File
    
13.             End If
    
14.         Next
    
15.     End If
    
16.     Set SubFolders = ObjFolder.SubFolders
    
17.     If SubFolders.Count <> 0 Then
    
18.         For Each SubFolder In SubFolders
    
19.             strTmp = GetFileFolderList(SubFolder)
    
20.         Next
    
21.     End If
    
22.     GetFileFolderList = strTmp
    
23. End Function
    
24. 
    
25. Sub yy()
    
26.     Dim fso, folder, myPath$, Filename$, wb1 As Workbook, m&, Arr
    
27.     Dim Sht1 As Worksheet, i&, nm1$, wbnm$, sh As Worksheet, Myr&, Myc&
    
28.     Application.ScreenUpdating = False
    
29.     r = 0
    
30.     myPath = ThisWorkbook.Path & ""
    
31.     Set wb1 = ThisWorkbook
    
32.     wbnm = Left(wb1.Name, Len(wb1.Name) - 4)
    
33.     Set fso = CreateObject("Scripting.FileSystemObject")
    
34.     Set folder = fso.GetFolder(myPath)
    
35.     strTmp = GetFileFolderList(folder)
    
36.     For i = 1 To r
    
37.         Filename = Arr1(i)
    
38.         nm1 = Split(Mid(Filename, InStrRev(Filename, "") + 1), ".")(0)
    
39.         If nm1 = wbnm Then GoTo 200
    
40.         Workbooks.Open Filename
    
41.         Dim wb As Workbook
    
42.         Set wb = ActiveWorkbook
    
43.         For Each sh In wb.Sheets
    
44.             Myr = sh.[b65536].End(xlUp).Row
    
45.             Myc = sh.[iv2].End(xlToLeft).Column
    
46.             nm = sh.Name
    
47.             If Myr > 2 Then
    
48.                 Arr = Range("a3", Cells(Myr, Myc))
    
49.                 With wb1.Sheets(nm)
    
50.                     m = .[b65536].End(xlUp).Row + 1
    
51.                     .Cells(m, 1).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
    
52.                 End With
    
53.             End If
    
54.         Next
    
55.         wb.Close savechanges:=False
    
56.         Set wb = Nothing
    
57. 200:
    
58.     Next
    
59.     Application.ScreenUpdating = True
    
60. End Sub
    
61. 
    

复制代码

蓝桥玄霜

请见附件。

奥巴马学VBA

谢谢版主的回复。但是我真实的数据中汇总会出现错误。。。有一些工作表表里面没有汇总到任何一个数据。有一些表里汇总后会出现错列的现象。我看了表格的列顺序都是一样的。不知道问题在哪里。由于涉及数据的保密性。我修改后再上传上来。到时麻烦请版主再看看。可能要晚上才能上传上来。谢谢

奥巴马学VBA

蓝桥玄霜 发表于 2012-2-21 10:37
请见附件。

老师你好。麻烦你再看看我的问题。我在附件中说明。谢谢,用了你的这个代码去汇总后。全部出现错乱。不知道我应该要注意一些什么。谢谢



11.rar (88.3 KB, 下载次数: 27)

2012-2-21 20:28 上传

点击文件名下载附件

蓝桥玄霜

1. Sub yy()
   
2.     Dim fso, folder, myPath$, Filename$, wb1 As Workbook, m&, Arr
   
3.     Dim Sht1 As Worksheet, i&, nm1$, wbnm$, sh As Worksheet, Myr&, Myc&
   
4.     Application.ScreenUpdating = False
   
5.     r = 0
   
6.     myPath = ThisWorkbook.Path & ""
   
7.     Set wb1 = ThisWorkbook
   
8.     wbnm = Left(wb1.Name, Len(wb1.Name) - 4)
   
9.     Set fso = CreateObject("Scripting.FileSystemObject")
   
10.     Set folder = fso.GetFolder(myPath)
    
11.     strTmp = GetFileFolderList(folder)
    
12.     For i = 1 To r
    
13.         Filename = Arr1(i)
    
14.         nm1 = Split(Mid(Filename, InStrRev(Filename, "") + 1), ".")(0)
    
15.         If nm1 = wbnm Then GoTo 200
    
16.         Workbooks.Open Filename
    
17.         Dim wb As Workbook
    
18.         Set wb = ActiveWorkbook
    
19.         For Each sh In wb.Sheets
    
20.             Myr = sh.[b65536].End(xlUp).Row
    
21.             Myc = sh.[iv2].End(xlToLeft).Column
    
22.             nm = sh.Name
    
23.             If Myr > 2 Then
    
24.                 Arr = sh.Range("a3", sh.Cells(Myr, Myc))
    
25.                 With wb1.Sheets(nm)
    
26.                     m = .[b65536].End(xlUp).Row + 1
    
27.                     .Cells(m, 1).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
    
28.                 End With
    
29.             End If
    
30.         Next
    
31.         wb.Close savechanges:=False
    
32.         Set wb = Nothing
    
33. 200:
    
34.     Next
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    
37. 
    

复制代码

蓝桥玄霜

请见附件。

奥巴马学VBA

蓝桥玄霜 发表于 2012-2-21 20:51
请见附件。

老师。。我看了基本都可以了。但是还有一个问题。集团帐号申请这个工作表。。按我7楼给的文件来测试的话，只汇总到了张三工作簿的。没有汇总到李四工作簿里面的集团账号申请表