同一个文件夹里，如何自动提取该文件夹内所有文件的指定单元格的数据存入一个指定...

xmu1122

有：文件XXX   文件XXX  文件XXX   文件XXX ~~一系列不同文件（文件个数在文件夹下可能会填加，名称都是一个样式 但是是模板除了内容不一样，其他都一样，需要汇总每个文件里的打分数值还有公司名字放在汇总表里），但放在同一个文件夹里，如何自动提取该文件夹内所有文件的指定单元格的数据存入一个指定的另一个文件里的统计表里。
注：不能打开源 XXX-test1.0.xls文件

liulang0808

http://club.excelhome.net/thread-1165866-1-1.html
参考下

zhaogang1960

ADO法速度很快，请参考：

1. Sub ADO法()
   
2.     Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, m&, arr()
   
3.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
4.     ReDim arr(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count, 1 To 2)
   
5.     For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
   
6.         If File.Name Like "*.xlsx" Then
   
7.             m = m + 1
   
8.             Set cnn = CreateObject("ADODB.Connection")
   
9.             cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & File
   
10.             Set rs = cnn.Execute("[Sheet1$a2:a2]")
    
11.             arr(m, 1) = rs.Fields(0)
    
12.             Set rs = cnn.Execute("[Sheet1$g41:g41]")
    
13.             arr(m, 2) = rs.Fields(0)
    
14.         End If
    
15.     Next
    
16.     ActiveSheet.UsedRange.Offset(1).ClearContents
    
17.     If m > 0 Then [a2].Resize(m, 2) = arr
    
18.     rs.Close
    
19.     cnn.Close
    
20.     Set rs = Nothing
    
21.     Set cnn = Nothing
    
22.     Set Fso = Nothing
    
23. End Sub
    

复制代码

zhaogang1960

请测试附件
文件Important.rar (21.63 KB, 下载次数: 301)

2015-8-5 09:07 上传

点击文件名下载附件

xmu1122

zhaogang1960 发表于 2015-8-5 09:07
请测试附件

首先，非常感谢你你的帮忙，我的实际源1的表格位置都是固定的，需要麻烦你帮帮忙，再帮我看看，我下载下来，还是会报错，运行时错误'91';
对象变量或with块变量未设置，
这个应该怎么修改啊？
麻烦了

zhaogang1960

xmu1122 发表于 2015-8-5 09:34
首先，非常感谢你你的帮忙，我的实际源1的表格位置都是固定的，需要麻烦你帮帮忙，再帮我看看，我下载下 ...

请说明是哪一句报错

xmu1122

zhaogang1960 发表于 2015-8-5 09:36
请说明是哪一句报错

file:///C:\Users\hf_muxf\AppData\Roaming\Tencent\Users\1290927987\QQ\WinTemp\RichOle\B8XIP9@OUAPPX9BUTGU]E0I.png

zhaogang1960

xmu1122 发表于 2015-8-5 09:40

如果结果正确，可删除出错这一句

zhaogang1960

如果还出错，说明你的电脑不支持ADO，请测试下面常规法：

1. Sub 常规法()
   
2.     Dim Fso As Object, File As Object, m&, arr()
   
3.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
4.     ReDim arr(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count, 1 To 2)
   
5.     For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
   
6.         If File.Name Like "*.xlsx" Then
   
7.             m = m + 1
   
8.             With GetObject(File)
   
9.                 With .Sheets(1)
   
10.                     arr(m, 1) = .[a2]
    
11.                     arr(m, 2) = .[g41]
    
12.                 End With
    
13.                 .Close 0
    
14.             End With
    
15.         End If
    
16.     Next
    
17.     ActiveSheet.UsedRange.Offset(1).ClearContents
    
18.     If m > 0 Then [a2].Resize(m, 2) = arr
    
19.     Set Fso = Nothing
    
20. End Sub

复制代码

xmu1122

zhaogang1960 发表于 2015-8-5 09:46
如果结果正确，可删除出错这一句

关键是文档在我这里，就没有结果，点了按钮直接报错，没有任何结果