批量提取一个文件下的多个工作簿指定的单元格内容到新表

commend

好论坛，好好学习下。用得着。

老婆老婆

能帮忙吗？

sogo777

zhaogang1960 发表于 2016-1-25 17:10
结果放在一张表上，请参考：
Sub ADO法()
    Dim Fso As Object, File As Object, cnn As Object, SQL$, ...

1. Sub ADO()
   
2.     Dim Fso As Object, File As Object, cnn As Object, SQL$, m&, n&, arr, brr(1 To 100000, -1 To 2), i&, j&
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
6.     Set cnn = CreateObject("adodb.connection")
   
7.     GZB = InputBox("请输入： 要提取的工作表名称，输入“*”为提取所有工作表。")
   
8.     QYFW = InputBox("请输入： 要提取的区域，输入“*”为提取所有有数据的区域")
   
9.     For Each File In Fso.GetFolder(CreateObject("scripting.filesystemobject").GetFolder(ThisWorkbook.Path) & "\分表").Files
   
10.         If File.Name Like "*.xls*" Then
    
11.             n = n + 1
    
12.             If n = 1 Then
    
13.                 cnn.Open "provider=microsoft.Ace.oledb.12.0;extended properties=excel 12.0;data source=" & File
    
14.                 SQL = "select * from [" & GZB & "$" & QYFW & "]"
    
15.             Else
    
16.                 SQL = "select * from [Excel 12.0;Database=" & File & ";].[" & GZB & "$" & QYFW & "]"
    
17.             End If
    
18.             arr = cnn.Execute(SQL).GetRows
    
19.             brr(m + 1, -1) = n
    
20.             For i = 0 To UBound(arr, 2)
    
21.                 If IsNull(arr(0, i)) Then Exit For
    
22.                 m = m + 1
    
23.                 For j = 0 To 2
    
24.                     brr(m, j) = arr(j, i)
    
25.                 Next
    
26.             Next
    
27.         End If
    
28.     Next
    
29.     ActiveSheet.UsedRange.Offset(2).ClearContents
    
30.     Range("A3").Resize(m, 3) = brr
    
31.     cnn.Close
    
32.     Set cnn = Nothing
    
33.     Set File = Nothing
    
34.     Set Fso = Nothing
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    

复制代码

赵老师，我修改了一下您的代码，想自己自定义工作表名称和提取区域。但是我是初学者，改了一半，后面不会改了。您能帮我看一下吗

LMY123

SQL合并同夹，另一子文件下多薄指定表3列数据

补充内容 (2019-1-1 15:08):
单夹_多薄_指定表_合并成一薄一表_ADO加数组法,已入库

hyw11

zhaogang1960 发表于 2016-1-25 17:10
结果放在一张表上，请参考：
Sub ADO法()
    Dim Fso As Object, File As Object, cnn As Object, SQL$, ...

版主，我有同样的表格，但是要统计的列数是A4:V16的内容，请版主帮忙。谢谢！

xiaovba

zhaogang1960 发表于 2016-1-25 17:10
结果放在一张表上，请参考：
Sub ADO法()
    Dim Fso As Object, File As Object, cnn As Object, SQL$, ...

  Dim Fso As Object, File As Object, cnn As Object, SQL$, m&, n&, arr, brr(1 To 100000, -1 To 2), i&, j&

请教版主，为什么定义变量的时候brr会这么定义？

JGY611

！！！！！！！！！！！！！！！！！！！

becloser

zhaogang1960 发表于 2016-1-25 17:11
请测试附件

很厉害，但我看不懂，大哥，能不能帮我看看这个，我只会一个文件一个文件打开再关闭，看过你的帖子，是区域选择的，能有单独个别零散的单元格提取吗？而且有些文件要输入密码，谢谢！有时间帮我看看吧http://club.excelhome.net/thread-1479250-1-1.html

myassz

zhaogang1960 发表于 2016-1-26 18:42
下面附件有20个工作簿，常规法速度下降不少，请测试：

谢谢zhaogang1960版主！
这个太好了！

myassz

谢谢zhaogang1960版主！
这个太好了！