如何遍历文件夹内所有文件寻找符合条件的sheet表并汇总

霏霏妈

建设公司下面有很多项目经理（workbook），每个项目经理下面又有很多项目（sheet表），每个项目的数据格式都是一致的。现在根据汇总表里B1-R1的项目代码，遍历其他所有的文件sheet页，找出对应项目代码页里面自开工以来的累计数（即E8-E41 ）   填入汇总表内。。具体数字详见附件。，估计得用VBA了 谢谢大家！！

霏霏妈

已上传文件  坐等大神帮忙！！

zhaogang1960

请参考:

1. Sub ADO加字典法()
   
2.     Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, c, s$, arr, brr(), i&, d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Range("A1").CurrentRegion
   
5.     For i = 2 To UBound(arr, 2)
   
6.         d("" & arr(1, i)) = i
   
7.     Next
   
8.     ReDim brr(0 To 33, 2 To i - 1)
   
9.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
10.     For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
    
11.         If LCase(File.Name) Like "*.xls" And LCase(File.Name) <> ThisWorkbook.Name Then
    
12.             Set cnn = CreateObject("adodb.connection")
    
13.             cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & File
    
14.             Set rs = cnn.OpenSchema(20)
    
15.             Do Until rs.EOF
    
16.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
17.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
18.                     If Right(s, 1) = "$" Then
    
19.                         c = d(Left$(s, 7))
    
20.                         If c <> "" Then
    
21.                             SQL = "select * from [" & s & "E8:E41]"
    
22.                             arr = cnn.Execute(SQL).GetRows
    
23.                             For i = 0 To 33
    
24.                                 If Not IsNull(arr(0, i)) Then brr(i, c) = arr(0, i)
    
25.                             Next
    
26.                         End If
    
27.                     End If
    
28.                 End If
    
29.                 rs.MoveNext
    
30.             Loop
    
31.         End If
    
32.     Next
    
33.     Range("b2").Resize(34, UBound(brr, 2) - 1) = brr
    
34.     rs.Close
    
35.     cnn.Close
    
36.     Set rs = Nothing
    
37.     Set cnn = Nothing
    
38.     Set File = Nothing
    
39.     Set Fso = Nothing
    
40. End Sub
    

复制代码

zhaogang1960

请测试附件
成本汇总表.rar (114.93 KB, 下载次数: 172)

2015-6-23 16:17 上传

点击文件名下载附件

霏霏妈

版主好棒！~初步测试无误，明天拿去单位再试验 万分感谢！

霏霏妈

公司软件导出的格式如下，并不是标准格式的XLS

霏霏妈

zhaogang1960 发表于 2015-6-23 16:17
请测试附件

版主老师，运行到13行报错。报错提示： 不是外部预期的格式。  我看了下公司实际导出的文件的确格式是不一样的，具体看6楼附件   13行代码应该要改改。但是我不会改 帮忙一下 呵呵 谢谢

zhaogang1960

霏霏妈 发表于 2015-6-24 08:38
版主老师，运行到13行报错。报错提示： 不是外部预期的格式。  我看了下公司实际导出的文件的确格式是不 ...

你导出的是2007格式工作簿，在2003中打不开，请在2007中使用：

1. Sub ADO加字典法() '在2007中使用
   
2.     Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, c, s$, arr, brr(), i&, d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Range("A1").CurrentRegion
   
5.     For i = 2 To UBound(arr, 2)
   
6.         d("" & arr(1, i)) = i
   
7.     Next
   
8.     ReDim brr(0 To 33, 2 To i - 1)
   
9.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
10.     For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
    
11.         If LCase(File.Name) Like "*.xls" Then
    
12.             Set cnn = CreateObject("adodb.connection")
    
13.             cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;hdr=no';data source=" & File
    
14.             Set rs = cnn.OpenSchema(20)
    
15.             Do Until rs.EOF
    
16.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
17.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
18.                     If Right(s, 1) = "$" Then
    
19.                         c = d(Left$(s, 7))
    
20.                         If c <> "" Then
    
21.                             SQL = "select * from [" & s & "E8:E41]"
    
22.                             arr = cnn.Execute(SQL).GetRows
    
23.                             For i = 0 To 33
    
24.                                 If Not IsNull(arr(0, i)) Then brr(i, c) = arr(0, i)
    
25.                             Next
    
26.                         End If
    
27.                     End If
    
28.                 End If
    
29.                 rs.MoveNext
    
30.             Loop
    
31.         End If
    
32.     Next
    
33.     Range("b2").Resize(34, UBound(brr, 2) - 1) = brr
    
34.     rs.Close
    
35.     cnn.Close
    
36.     Set rs = Nothing
    
37.     Set cnn = Nothing
    
38.     Set File = Nothing
    
39.     Set Fso = Nothing
    
40. End Sub
    

复制代码

zhaogang1960

也可以使用常规法：

1. Sub 常规法() '在2007中使用
   
2.     Dim Fso As Object, File As Object, c, s$, arr, brr(), i&, d As Object, sh As Worksheet
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Range("A1").CurrentRegion
   
7.     For i = 2 To UBound(arr, 2)
   
8.         d("" & arr(1, i)) = i
   
9.     Next
   
10.     ReDim brr(1 To 34, 2 To i - 1)
    
11.     Set Fso = CreateObject("Scripting.FileSystemObject")
    
12.     For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
    
13.         If LCase(File.Name) Like "*.xls" Then
    
14.             With GetObject(File)
    
15.                 For Each sh In .Worksheets
    
16.                     c = d(Left$(sh.Name, 7))
    
17.                     If c <> "" Then
    
18.                         arr = sh.Range("E8:E41")
    
19.                         For i = 1 To UBound(arr)
    
20.                             brr(i, c) = arr(i, 1)
    
21.                         Next
    
22.                     End If
    
23.                 Next
    
24.                 .Close 0
    
25.             End With
    
26.         End If
    
27.     Next
    
28.     Range("b2").Resize(34, UBound(brr, 2) - 1) = brr
    
29.     Set File = Nothing
    
30.     Set Fso = Nothing
    
31.     Application.ScreenUpdating = True
    
32. End Sub
    

复制代码

zhaogang1960

下面附件中有这两种方法：
成本汇总表.rar (116.22 KB, 下载次数: 173)

2015-6-24 10:17 上传

点击文件名下载附件