不同文件夹下相同类型工作表数据汇总

beleqing

我的问题如图所示，附件在此，大神们可否帮忙写段代码！谢谢！

产量统计.rar (24.81 KB, 下载次数: 26)

2013-12-29 21:24 上传

点击文件名下载附件

zhaogang1960

请测试：

1. Sub 宏1()
   
2.     Dim cnn As Object, SQL$, Mypath$, MyFile$, m&, n&, t$
   
3.     Dim Fso As Object, arrf$(), mf&, sFileType$, j&
   
4.     Application.ScreenUpdating = False
   
5.     sFileType = "*.xlsx"
   
6.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
7.     Call GetFiles(ThisWorkbook.Path, sFileType, Fso, arrf, mf)
   
8.     ActiveSheet.UsedRange.Offset(1).ClearContents
   
9.     Set cnn = CreateObject("ADODB.Connection")
   
10.     cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & arrf(1)
    
11.    
    
12.     For j = 1 To mf
    
13.         m = m + 1
    
14.         If m > 49 Then
    
15.             Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
16.             m = 1
    
17.             SQL = ""
    
18.         End If
    
19.         If Len(SQL) Then SQL = SQL & " union all "
    
20.         SQL = SQL & "select * from [Excel 12.0;Database=" & arrf(j) & "].[Sheet1$]"
    
21.     Next
    
22.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
23.     cnn.Close
    
24.     Set cnn = Nothing
    
25.     Set Fso = Nothing
    
26.     Application.ScreenUpdating = True
    
27. End Sub
    
28. 
    
29. Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
    
30.     Dim Folder As Object
    
31.     Dim SubFolder As Object
    
32.     Dim File As Object
    
33.     Set Folder = Fso.GetFolder(sPath)
    
34.     If sPath <> ThisWorkbook.Path Then
    
35.         For Each File In Folder.Files
    
36.             If File.Name Like sFileType Then
    
37.                 mf = mf + 1
    
38.                 ReDim Preserve arrf(1 To mf)
    
39.                 arrf(mf) = sPath & "" & File.Name
    
40.             End If
    
41.         Next
    
42.     End If
    
43.     If Folder.SubFolders.Count > 0 Then
    
44.         For Each SubFolder In Folder.SubFolders
    
45.             Call GetFiles(SubFolder.Path, sFileType, Fso, arrf, mf)
    
46.         Next
    
47.     End If
    
48.     Set Folder = Nothing
    
49.     Set File = Nothing
    
50.     Set SubFolder = Nothing
    
51. End Sub
    

复制代码

zhaogang1960

请看附件
产量统计.rar (38.9 KB, 下载次数: 52)

2013-12-29 23:33 上传

点击文件名下载附件

VBAliker

我做了一个，你看行吗？是用excel2003做的，在2007下应该也能行。你试试吧。订单工作薄的名称无所谓，但要保证数据都在订单工作薄的sheet1表中。

beleqing

zhaogang1960 发表于 2013-12-29 21:45
请看附件

哇，先感谢大版主的悉心解答！！！但是我测试了一下，发现只有：

产品号        高度        长度
770        2        34
771        23        1
773        45        23
774        34        23
777        12        54
770        2        34
771        23        1
773        45        23
774        34        23
777        12        54
770        2        34
771        23        1
773        45        23
774        34        23
777        12        54

而不是想要得到的：

产品号        高度        长度
110        10        34
111        23        12
112        32        45
200        10        23
770        2        34
771        23        1
773        45        23
774        34        23
777        12        54

请问哪里出错了？多谢！

beleqing

VBAliker 发表于 2013-12-29 22:24
我做了一个，你看行吗？是用excel2003做的，在2007下应该也能行。你试试吧。订单工作薄的名称无所谓，但要保 ...

先谢谢高手花时间帮助我，但是我想得到产品号/高度/长度的统计数据，就像我写在5楼那样的，请问有什么办法吗？

zhaogang1960

beleqing 发表于 2013-12-29 22:35
先谢谢高手花时间帮助我，但是我想得到产品号/高度/长度的统计数据，就像我写在5楼那样的，请问有什么办法 ...

我是把所有的全部复制过来了，请说明哪一个不要了

beleqing

110        10        34
111        23        12
112        32        45
这些数据来源于产量统计\产品种类1\订单1.xlsx

200        10        23
这些数据来源于产量统计\产品种类1\订单02.xlsx

770        2        34
771        23        1
773        45        23
774        34        23
777        12        54
这些数据来源于产量统计\产品种类02\订单号码01.xlsx

也就是遍历产品统计文件夹下所有子文件夹内的所有excel表格。把这些excel表格内的数据统计到汇总表里！谢谢！！

大版主你做的是把产量统计\产品种类02\订单号码01.xlsx这个表格统计了三遍{:soso_e112:}

zhaogang1960

beleqing 发表于 2013-12-29 23:24
110        10        34
111        23        12
112        32        45

修改如下：

1. Sub 宏1()
   
2.     Dim cnn As Object, SQL$, Mypath$, MyFile$, m&, n&, t$
   
3.     Dim Fso As Object, arrf$(), mf&, sFileType$, j&
   
4.     Application.ScreenUpdating = False
   
5.     sFileType = "*.xlsx"
   
6.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
7.     Call GetFiles(ThisWorkbook.Path, sFileType, Fso, arrf, mf)
   
8.     ActiveSheet.UsedRange.Offset(1).ClearContents
   
9.     Set cnn = CreateObject("ADODB.Connection")
   
10.     cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & arrf(1)
    
11.    
    
12.     For j = 1 To mf
    
13.         m = m + 1
    
14.         If m > 49 Then
    
15.             Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
16.             m = 1
    
17.             SQL = ""
    
18.         End If
    
19.         If Len(SQL) Then SQL = SQL & " union all "
    
20.         SQL = SQL & "select * from [Excel 12.0;Database=" & arrf(j) & "].[Sheet1$]"
    
21.     Next
    
22.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
23.     cnn.Close
    
24.     Set cnn = Nothing
    
25.     Set Fso = Nothing
    
26.     Application.ScreenUpdating = True
    
27. End Sub
    
28. 
    
29. Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
    
30.     Dim Folder As Object
    
31.     Dim SubFolder As Object
    
32.     Dim File As Object
    
33.     Set Folder = Fso.GetFolder(sPath)
    
34.     If sPath <> ThisWorkbook.Path Then
    
35.         For Each File In Folder.Files
    
36.             If File.Name Like sFileType Then
    
37.                 mf = mf + 1
    
38.                 ReDim Preserve arrf(1 To mf)
    
39.                 arrf(mf) = sPath & "" & File.Name
    
40.             End If
    
41.         Next
    
42.     End If
    
43.     If Folder.SubFolders.Count > 0 Then
    
44.         For Each SubFolder In Folder.SubFolders
    
45.             Call GetFiles(SubFolder.Path, sFileType, Fso, arrf, mf)
    
46.         Next
    
47.     End If
    
48.     Set Folder = Nothing
    
49.     Set File = Nothing
    
50.     Set SubFolder = Nothing
    
51. End Sub
    

复制代码

jjmysjg

zhaogang1960 发表于 2013-12-29 21:44
请测试：

zhaogang版主你好:
帮我看看帖子好吗。
谢谢！
http://club.excelhome.net/forum. ... =1084490&extra=