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

dg831451

好有耐心。。。

奥巴马学VBA

版主麻烦你再看一下,我不知道是不是我操问题还是如何,还是不对，弹出错误对话框而且汇总的数据也不正确
由于我不能一次传较大文件。我分卷压缩上传一个动画。麻烦你看看。谢谢


错误.part1.rar (234.38 KB, 下载次数: 24)

2012-2-22 15:31 上传

点击文件名下载附件

错误.part2.rar (200.45 KB, 下载次数: 26)

2012-2-22 15:32 上传

点击文件名下载附件

zuiaidh2004

蓝版好有耐心啊。。

蓝桥玄霜

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, 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
    
38. 是代码中的问题。

复制代码

奥巴马学VBA

版主。你好。不好意思。还是和动画弹出一样的错误提示。而且汇总还是不对。{:soso_e109:}

蓝桥玄霜

请把你测试的附件重新上传看看。

蓝桥玄霜

或者试试这段代码：

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, 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 InStr(nm1, wbnm) Or Left(nm1, 1) = "$" 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
    

复制代码

奥巴马学VBA

这次不弹出错误对话框了。但是张三07的格式又汇总不到了。用你16楼与27楼结合的代码还是不行。在14楼之前的几次修改，如果没有03的格式是完全可以的。但是加了07的格式后现在用16楼与27楼的代码使终不行。


问题.rar (99.31 KB, 下载次数: 116)

2012-2-22 20:44 上传

点击文件名下载附件

奥巴马学VBA

版主。能否麻烦你再帮忙看看。或者其他的朋友如果会的话也请帮忙看看。谢谢

蓝桥玄霜

奥巴马学VBA 发表于 2012-2-22 20:44
这次不弹出错误对话框了。但是张三07的格式又汇总不到了。用你16楼与27楼结合的代码还是不行。在14楼之前的 ...

办公室电脑是03版本的，只能晚上回家测试了。