遍历文件夹下的工作簿、工作表进行取数，无需打开文件，求助。

whggwu

    现有一批数据特点如下：

1、工作簿在该文件夹会有增加，无规律，需要遍历文件夹。
2、每个工作簿的工作表都会有增加，名称无规律，工作表也要遍历。
3、每个工作表的结构完全相同，项目字段内容有空值或零值的可能，如果遇此情况就返回相应的空值或零值。
4、希望返回的数据有工作簿名称、工作表名称等等字段，详细请看附件。

    鄙人对VBA也还不太清楚，会看会改一些代码以符合自己的需求，希望EH坛友帮忙，谢谢！
HelpSample.zip (34.9 KB, 下载次数: 246)

2012-4-15 22:55 上传

点击文件名下载附件

zhaogang1960

短信收到，第一个问题请参考：

1. Sub Macro1()
   
2. '引用Microsoft AD0 Ext 2.8 for DDL and Security
   
3. '引用Microsoft ActiveX Data Objects 2.x Library
   
4.     Dim cnn As New ADODB.Connection
   
5.     Dim rs As ADODB.Recordset
   
6.     Dim cat  As New ADOX.Catalog, tb1 As Table
   
7.     Dim SQL$, MyFile$, m%, i%, temp$, strField$, s$, t$, n%
   
8.     Mypath = ThisWorkbook.Path & ""
   
9.     MyFile = Dir(Mypath & "*.xlsx")
   
10.     Do While MyFile <> ""
    
11.         If MyFile <> ThisWorkbook.Name Then
    
12.             n = n + 1
    
13.             If n > 1 Then
    
14.                 t = "[Excel 12.0;Database=" & Mypath & MyFile & "]."
    
15.             Else
    
16.                 cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyFile
    
17.             End If
    
18.             cat.ActiveConnection = "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=No';Data Source=" & Mypath & MyFile
    
19.             For Each tb1 In cat.Tables
    
20.                 If tb1.Type = "TABLE" Then
    
21.                     s = Replace(tb1.Name, "'", "")
    
22.                     If Right(s, 1) = "$" Then
    
23.                         m = m + 1
    
24.                         If m = 1 Then
    
25.                             Set rs = cnn.Execute("[" & s & "a5:d]")
    
26.                             For i = 0 To rs.Fields.Count - 1
    
27.                                 temp = temp & rs.Fields(i).Name & ","
    
28.                             Next
    
29.                         End If
    
30.                         If SQL <> "" Then SQL = SQL & " union all "
    
31.                         SQL = SQL & "select " & temp & "'" & Replace(s, "$", "") & "' as 工作表,'" & Replace(MyFile, ".xlsx", "") & "' as 工作簿 from " & t & "[" & s & "a5:d]"
    
32.                     End If
    
33.                 End If
    
34.             Next
    
35.         End If
    
36.         MyFile = Dir()
    
37.     Loop
    
38.     [a1].CurrentRegion.Offset(3).ClearContents
    
39.     [a4].CopyFromRecordset cnn.Execute(SQL)
    
40.     cnn.Close
    
41.     Set rs = Nothing
    
42.     Set cnn = Nothing
    
43.     Set cat = Nothing
    
44.     Set tb1 = Nothing
    
45. End Sub
    

复制代码

zhaogang1960

请看附件
HelpSample.rar (50.16 KB, 下载次数: 418)

2012-4-16 00:31 上传

点击文件名下载附件

zhaogang1960

第二个问题：

1. Sub Macro2()
   
2. '引用Microsoft AD0 Ext 2.8 for DDL and Security
   
3. '引用Microsoft ActiveX Data Objects 2.x Library
   
4.     Dim cnn As New ADODB.Connection
   
5.     Dim rs As ADODB.Recordset
   
6.     Dim cat  As New ADOX.Catalog, tb1 As Table
   
7.     Dim SQL$, MyFile$, i%, temp$, strField$, s$, t$, n%
   
8.     Mypath = ThisWorkbook.Path & ""
   
9.     MyFile = Dir(Mypath & "*.xlsx")
   
10.     Do While MyFile <> ""
    
11.         If MyFile <> ThisWorkbook.Name Then
    
12.             n = n + 1
    
13.             If n > 1 Then
    
14.                 t = "[Excel 12.0;HDR=No;Database=" & Mypath & MyFile & "]."
    
15.             Else
    
16.                 cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=No';Data Source=" & Mypath & MyFile
    
17.             End If
    
18.             cat.ActiveConnection = "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=No';Data Source=" & Mypath & MyFile
    
19.             For Each tb1 In cat.Tables
    
20.                 If tb1.Type = "TABLE" Then
    
21.                     s = Replace(tb1.Name, "'", "")
    
22.                     If Right(s, 1) = "$" Then
    
23.                         If SQL <> "" Then SQL = SQL & " union all "
    
24.                         SQL = SQL & "select " & "'" & Replace(MyFile, ".xlsx", "") & "' as 工作簿,'" & Replace(s, "$", "") & "' as 工作表,(select f1 from " & t & "[" & s & "b1:b1]),(select f1 from " & t & "[" & s & "b3:b3]),(select f1 from " & t & "[" & s & "e1:e1]) from " & t & "[" & s & "a1:e1]"
    
25.                     End If
    
26.                 End If
    
27.             Next
    
28.         End If
    
29.         MyFile = Dir()
    
30.     Loop
    
31.     [a1].CurrentRegion.Offset(3).ClearContents
    
32.     [a4].CopyFromRecordset cnn.Execute(SQL)
    
33.     cnn.Close
    
34.     Set rs = Nothing
    
35.     Set cnn = Nothing
    
36.     Set cat = Nothing
    
37.     Set tb1 = Nothing
    
38. End Sub
    

复制代码

jiminyanyan

赵老师V5，留个脚印先。。。

whggwu

zhaogang1960 发表于 2012-4-16 01:03
第二个问题：

深夜的回复，感激不尽！

不过使用的时候，第一个问题，文件夹下工作簿超过18（含18）个（不含总表）就提示运行错误，查询过于复杂，请问是本身就有一定局限性不能执行太多，还是什么原因嗯？
有没有其他办法，不用VBA也行，或者加载其他工具也行。
实在不行我就一次17个文件取数一次好了，赵老师不用那么费心了，还是非常感谢！

zhaogang1960

两个问题合并：

1. Sub Macro1()
   
2. '引用Microsoft AD0 Ext 2.8 for DDL and Security
   
3. '引用Microsoft ActiveX Data Objects 2.x Library
   
4.     Dim cnn As New ADODB.Connection
   
5.     Dim rs As ADODB.Recordset
   
6.     Dim cat  As New ADOX.Catalog, tb1 As Table
   
7.     Dim SQL$, MyFile$, m%, i%, temp$, strField$, s$, t$, t2$, n%
   
8.     Mypath = ThisWorkbook.Path & ""
   
9.     MyFile = Dir(Mypath & "*.xlsx")
   
10.     Do While MyFile <> ""
    
11.         If MyFile <> ThisWorkbook.Name Then
    
12.             n = n + 1
    
13.             If n > 1 Then
    
14.                 t = "[Excel 12.0;Database=" & Mypath & MyFile & "]."
    
15.             Else
    
16.                 cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyFile
    
17.             End If
    
18.             t2 = "[Excel 12.0;HDR=No;Database=" & Mypath & MyFile & "]."
    
19.             cat.ActiveConnection = "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=No';Data Source=" & Mypath & MyFile
    
20.             For Each tb1 In cat.Tables
    
21.                 If tb1.Type = "TABLE" Then
    
22.                     s = Replace(tb1.Name, "'", "")
    
23.                     If Right(s, 1) = "$" Then
    
24.                         m = m + 1
    
25.                         If m = 1 Then
    
26.                             Set rs = cnn.Execute("[" & s & "a5:d]")
    
27.                             For i = 0 To rs.Fields.Count - 1
    
28.                                 temp = temp & rs.Fields(i).Name & ","
    
29.                             Next
    
30.                         End If
    
31.                         
    
32.                         If SQL <> "" Then SQL = SQL & " union all "
    
33.                         SQL = SQL & "select " & temp & "'" & Replace(s, "$", "") & "' as 工作表,'" & Replace(MyFile, ".xlsx", "") & "' as 工作簿 from " & t & "[" & s & "a5:d]"
    
34.                         
    
35.                         If SQL2 <> "" Then SQL2 = SQL2 & " union all "
    
36.                         SQL2 = SQL2 & "select " & "'" & Replace(MyFile, ".xlsx", "") & "' as 工作簿,'" & Replace(s, "$", "") & "' as 工作表,(select f1 from " & t2 & "[" & s & "b1:b1]),(select f1 from " & t2 & "[" & s & "b3:b3]),(select f1 from " & t2 & "[" & s & "e1:e1]) from " & t2 & "[" & s & "a1:e1]"
    
37.                     End If
    
38.                 End If
    
39.             Next
    
40.         End If
    
41.         MyFile = Dir()
    
42.     Loop
    
43.     With Sheets("项目取数")
    
44.         .[a1].CurrentRegion.Offset(3).ClearContents
    
45.         .[a4].CopyFromRecordset cnn.Execute(SQL)
    
46.     End With
    
47.     With Sheets("基础信息")
    
48.         .[a1].CurrentRegion.Offset(3).ClearContents
    
49.         .[a4].CopyFromRecordset cnn.Execute(SQL2)
    
50.     End With
    
51.     cnn.Close
    
52.     Set rs = Nothing
    
53.     Set cnn = Nothing
    
54.     Set cat = Nothing
    
55.     Set tb1 = Nothing
    
56. End Sub
    

复制代码

whggwu

zhaogang1960 发表于 2012-4-16 18:45
两个问题合并：

超过18个就会提示

zhaogang1960

whggwu 发表于 2012-4-16 18:53
超过18个就会提示

什么超过18个？

zhaogang1960

是文件数超过18个？确切地说是工作表数超过49个，如果是需要分步复制数据，请测试：

1. Sub Macro1()
   
2. '引用Microsoft AD0 Ext 2.8 for DDL and Security
   
3. '引用Microsoft ActiveX Data Objects 2.x Library
   
4.     Dim cnn As New ADODB.Connection
   
5.     Dim rs As ADODB.Recordset
   
6.     Dim cat  As New ADOX.Catalog, tb1 As Table
   
7.     Dim d As Object, ds As Object
   
8.     Dim SQL$, MyFile$, m%, i%, temp$, strField$, s$, t$, t2$, n%
   
9.     Application.ScreenUpdating = False
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     Set ds = CreateObject("scripting.dictionary")
    
12.     Sheets("项目取数").[a1].CurrentRegion.Offset(3).ClearContents
    
13.     Sheets("基础信息").[a1].CurrentRegion.Offset(3).ClearContents
    
14.     Mypath = ThisWorkbook.Path & ""
    
15.     MyFile = Dir(Mypath & "*.xlsx")
    
16.     Do While MyFile <> ""
    
17.         If MyFile <> ThisWorkbook.Name Then
    
18.             n = n + 1
    
19.             If n > 1 Then
    
20.                 t = "[Excel 12.0;Database=" & Mypath & MyFile & "]."
    
21.             Else
    
22.                 cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyFile
    
23.             End If
    
24.             t2 = "[Excel 12.0;HDR=No;Database=" & Mypath & MyFile & "]."
    
25.             cat.ActiveConnection = "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=No';Data Source=" & Mypath & MyFile
    
26.             For Each tb1 In cat.Tables
    
27.                 If tb1.Type = "TABLE" Then
    
28.                     s = Replace(tb1.Name, "'", "")
    
29.                     If Right(s, 1) = "$" Then
    
30.                         m = m + 1
    
31.                         If m = 1 Then
    
32.                             Set rs = cnn.Execute("[" & s & "a5:d]")
    
33.                             For i = 0 To rs.Fields.Count - 1
    
34.                                 temp = temp & rs.Fields(i).Name & ","
    
35.                             Next
    
36.                         End If
    
37.                         SQL = "select " & temp & "'" & Replace(s, "$", "") & "' as 工作表,'" & Replace(MyFile, ".xlsx", "") & "' as 工作簿 from " & t & "[" & s & "a5:d]"
    
38.                         d(SQL) = ""
    
39.                         SQL2 = "select " & "'" & Replace(MyFile, ".xlsx", "") & "' as 工作簿,'" & Replace(s, "$", "") & "' as 工作表,(select f1 from " & t2 & "[" & s & "b1:b1]),(select f1 from " & t2 & "[" & s & "b3:b3]),(select f1 from " & t2 & "[" & s & "e1:e1]) from " & t2 & "[" & s & "a1:e1]"
    
40.                         ds(SQL2) = ""
    
41.                         If m Mod 49 = 0 Then Call Replicated_data(d, ds, cnn)
    
42.                     End If
    
43.                 End If
    
44.             Next
    
45.         End If
    
46.         MyFile = Dir()
    
47.     Loop
    
48.     If d.Count > 0 Then Call Replicated_data(d, ds, cnn)
    
49.     rs.Close
    
50.     cnn.Close
    
51.     Set rs = Nothing
    
52.     Set cnn = Nothing
    
53.     Set cat = Nothing
    
54.     Set tb1 = Nothing
    
55.     Application.ScreenUpdating = True
    
56. End Sub
    
57. 
    
58. Sub Replicated_data(ByRef d As Object, ByRef ds As Object, ByRef cnn As Object)
    
59.     Dim SQL$
    
60.     SQL = Join(d.Keys, " UNION ALL ")
    
61.     Sheets("项目取数").[a65536].End(3).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
62.     SQL = Join(ds.Keys, " UNION ALL ")
    
63.     Sheets("基础信息").[a65536].End(3).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
64.     d.RemoveAll
    
65.     ds.RemoveAll
    
66. End Sub
    

复制代码