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

岁寒三友

#3将2,3两列数据搞反了，现已更改。

zhaogang1960

dengxiyin 发表于 2013-11-14 22:56
您好，版主，能否发一个excel附件及这个宏注释我。谢谢！

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") '创建Fso对象
    
12.     sFileType = "*.xls" '文件类型
    
13.     Call GetFiles(Mypath, sFileType, Fso) '调用查询所有子文件夹中的所有文件子程序
    
14.     For i = 1 To mf '逐个xls文件
    
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]") '先查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 'A1值
    
27.                         brr(m, 3) = cnn.Execute("[" & s & "a3:a3]").Fields(0).Value 'A3值
    
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
    

复制代码

Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, Fso As Object) '查询所有子文件夹中的所有文件子程序，原理不用管它

zhaogang1960

dengxiyin 发表于 2013-11-14 23:08
您好，版主，感谢你的解答，我在别的文件夹运用后提示：运行时错误'-2147217900（80040e14)':
无效的SQL ...

请上传出错文件夹和出错文件

LMY123

ADO+子文件夹，If rs.Fields(0).Value <> "" Then '如果有值