|
本帖最后由 aecn 于 2019-1-21 21:22 编辑
这段汇总代码是在论坛里找的,是汇总根目录下的.xls表格的数据,求大神帮改成指定子目录 /12月/ 文件夹里所有的EXCEL表格(包括.xls .xlsx .xlsm)的数据
特别需要,但自己能力有限,在此先谢谢各位大神了。
- Sub ADO法()
- Dim Fso As Object, File As Object, cnn As Object, RS As Object, sql$, n&, arr, brr(), i&
- Application.ScreenUpdating = False
- arr = [{"A5:A5","B5:B5","C5:C5","D5:D5","E5:E5","F5:F5","G5:G5","H5:H5","I5:I5","J5:J5","K5:K5","L5:L5","F27:F27","F28:F28","F30:F30","F32:F32","F33:F33"}]
- Set Fso = CreateObject("Scripting.FileSystemObject")
- ReDim brr(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count, 1 To 17)
- Set cnn = CreateObject("adodb.connection")
- For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
- If File.Name Like "*.xls" Then
- n = n + 1
- If n = 1 Then cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & File
- For i = 1 To 17
- sql = "select f1 from [Excel 12.0;hdr=no;Database=" & File & ";].[数据[ DISCUZ_CODE_0 ]quot; & arr(i) & "]" '名为“数据”的工作表
- Set RS = cnn.Execute(sql)
- brr(n, i) = RS.Fields(0)
- Next
- End If
- Next
- Sheet1.Range("A4:Q5000").ClearContents
- Range("A4").Resize(n, 17) = brr
- RS.Close
- cnn.Close
- Set RS = Nothing
- Set cnn = Nothing
- Set Fso = Nothing
- Application.ScreenUpdating = True
- End Sub
复制代码
|
|