把文件夹所有子文件中excel的某一列提取到同一个统计表中

dengxiyin

因需要把三百多个文件夹中excel（该表格含有多个工作薄）的A1和A3的数值提取到一个表格中，例如下面附件中的名称和编号等数值。高手最好帮我定义一个名称，我直接=这个名称就能得到其他表格中的A1或者A3的数据。我是小白，如有描述不清，请联系我！

dengxiyin

坐等版主或者高手帮我！在此先谢谢各位了！

岁寒三友

请测试        

dengxiyin

岁寒三友 发表于 2013-11-14 22:00
请测试

感谢您的解救，但我对VBA不懂，我把统计这张表格放到我别的文件夹中就不能用了，能否用公式或者我能够改动的数据让我灵活运用。谢谢

little-key

请参考：http://yyb.excelhome.net/features/t021/

zhaogang1960

ADO法请测试：

1. Dim arrf(), mf&
   
2. 
   
3. Sub Macro1()
   
4.     Dim Mypath$, Fso As Object, i&, m&, brr(1 To 60000, 1 To 3)
   
5.     Dim cnn As Object, rs As Object, rst As Object
   
6.     With Application.FileDialog(msoFileDialogFolderPicker)
   
7.         If .Show = False Then Exit Sub
   
8.         Mypath = .SelectedItems(1) ' & ""
   
9.     End With
   
10.     Application.ScreenUpdating = False
    
11.     Set Fso = CreateObject("Scripting.FileSystemObject")
    
12.     sFileType = "*.xls"
    
13.     Call GetFiles(Mypath, sFileType, Fso)
    
14.     For i = 1 To mf
    
15.         Set cnn = CreateObject("ADODB.Connection")
    
16.         cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & arrf(i)
    
17.         Set rst = cnn.OpenSchema(20) 'adSchemaTables
    
18.         Do Until rst.EOF
    
19.             If rst.Fields("TABLE_TYPE") = "TABLE" Then
    
20.                 s = Replace(rst("TABLE_NAME").Value, "'", "")
    
21.                 If Right(s, 1) = "$" Then
    
22.                     Set rs = cnn.Execute("[" & s & "a1:a1]")
    
23.                     If rs.Fields(0).Value <> "" Then
    
24.                         m = m + 1
    
25.                         brr(m, 1) = m
    
26.                         brr(m, 2) = rs.Fields(0).Value
    
27.                         brr(m, 3) = cnn.Execute("[" & s & "a3:a3]").Fields(0).Value
    
28.                     End If
    
29.                 End If
    
30.             End If
    
31.             rst.MoveNext
    
32.         Loop
    
33.     Next
    
34.     Range("A5:F65536").ClearContents
    
35.     [a5].Resize(m, 3) = brr
    
36.     rs.Close
    
37.     rst.Close
    
38.     cnn.Close
    
39.     Set rs = Nothing
    
40.     Set rst = Nothing
    
41.     Set cnn = Nothing
    
42.     mf = 0
    
43.     Erase arrf
    
44.     Set Fso = Nothing
    
45.     Application.ScreenUpdating = True
    
46. End Sub
    
47. 
    
48. Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, Fso As Object)
    
49.     Dim Folder As Object
    
50.     Dim SubFolder As Object
    
51.     Dim File As Object
    
52.     Set Folder = Fso.GetFolder(sPath)
    
53.     For Each File In Folder.Files
    
54.         If File.Name Like sFileType Then
    
55.             If File.Name <> ThisWorkbook.Name Then
    
56.                 mf = mf + 1
    
57.                 ReDim Preserve arrf(1 To mf)
    
58.                 arrf(mf) = sPath & "" & File.Name
    
59.             End If
    
60.         End If
    
61.     Next
    
62.     For Each SubFolder In Folder.SubFolders
    
63.         Call GetFiles(SubFolder.Path, sFileType, Fso)
    
64.     Next
    
65.     Set Folder = Nothing
    
66.     Set File = Nothing
    
67.     Set SubFolder = Nothing
    
68. End Sub
    
69. 
    
70. 
    

复制代码

dengxiyin

little-key 发表于 2013-11-14 22:28
请参考：http://yyb.excelhome.net/features/t021/

您好，版主，这个不对哦

zhaogang1960

没有固定文件夹，程序会提示你指定文件夹
请看附件
新建文件夹.rar (57.7 KB, 下载次数: 72)

2013-11-14 22:49 上传

点击文件名下载附件

dengxiyin

zhaogang1960 发表于 2013-11-14 22:48
ADO法请测试：

您好，版主，能否发一个excel附件及这个宏注释我。谢谢！

dengxiyin

zhaogang1960 发表于 2013-11-14 22:50
没有固定文件夹，程序会提示你指定文件夹
请看附件

您好，版主，感谢你的解答，我在别的文件夹运用后提示：运行时错误'-2147217900（80040e14)':
无效的SQL语句；期待‘DELETE'.'INSERT'.PROCEDURE'……