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

蓝桥玄霜

请检查一下各工作簿的表格名称是不是不一样，因为一般而言，有一个工作簿能测试成功，应该说明代码没有问题。

奥巴马学VBA

蓝桥玄霜 发表于 2012-2-22 08:07
请检查一下各工作簿的表格名称是不是不一样，因为一般而言，有一个工作簿能测试成功，应该说明代码没有问题 ...

老师你好，我把张三工作簿的（集团帐号申请)工作表复制到李四工作簿的(集团帐号申请)里面一样还是不行。能否麻烦再看一看集团帐号申请这二个工作表的情况。谢谢

蓝桥玄霜

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.[c65536].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
    

复制代码

奥巴马学VBA

谢谢蓝桥版主的多次帮助。感谢，这里真的太多热心的人。版主的耐心与水平都是值得我学习的。再次感谢版主，祝你一切都顺利

奥巴马学VBA

蓝桥玄霜 发表于 2012-2-22 08:07
请检查一下各工作簿的表格名称是不是不一样，因为一般而言，有一个工作簿能测试成功，应该说明代码没有问题 ...

不好意思。老师。我还有个问题。我把张三工作簿改成07的xlsx格式后。就汇总不到了。。不知道代码是不是这里的问题
wbnm = Left(wb1.Name, Len(wb1.Name) - 4)

蓝桥玄霜

把这个代码替换原来的代码。

1. Function GetFileFolderList(ObjFolder) As String
   
2.     Dim SubFolders, SubFolder, hz$
   
3.     Dim Files, File
   
4.     hz = "xls"  '指定后缀
   
5.     Set Files = ObjFolder.Files
   
6.     If Files.Count <> 0 Then
   
7.         For Each File In Files
   
8.             If InStr(File, hz) Then
   
9.                 r = r + 1
   
10.                 ReDim Preserve Arr1(1 To r)
    
11.                 Arr1(r) = File
    
12.             End If
    
13.         Next
    
14.     End If
    
15.     Set SubFolders = ObjFolder.SubFolders
    
16.     If SubFolders.Count <> 0 Then
    
17.         For Each SubFolder In SubFolders
    
18.             strTmp = GetFileFolderList(SubFolder)
    
19.         Next
    
20.     End If
    
21.     GetFileFolderList = strTmp
    
22. End Function
    

复制代码

奥巴马学VBA

蓝桥玄霜 发表于 2012-2-22 13:45
把这个代码替换原来的代码。

谢谢版主，虽然点击后能够把07的格式正确得到了。但是会弹出这个错误提示。。就是说我点击结束，它其实已经汇总好了。

蓝桥玄霜

替换这段代码看看。

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

复制代码

奥巴马学VBA

蓝桥玄霜 发表于 2012-2-22 14:07
替换这段代码看看。

不好意思。还是没有成功。版主麻烦你点击看看你电脑运行我这个压缩包的附件是什么效果。我这里还是会弹出错误对话框。而且这次汇总后的数据又不对了。


问题.rar (100.24 KB, 下载次数: 44)

2012-2-22 14:29 上传

点击文件名下载附件

蓝桥玄霜

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

复制代码