VBA求助!如何遍历文件夹中的XLS文件并进行相应操作?

zhulx_wx

求高手指点!

附件是一个XLS文件的文件夹
我想把里面每个"随件单"中的"工作表目录"的内容,全都复制到"项目统计表.xls"中,
看了论坛里很多的资料,但是一直都不是很明白,
想请各位高手指教一下,
究竟是用GetObject来实现,还是用SQL来实现更简单呢?

liulang0808

http://club.excelhome.net/thread-1165866-1-1.html
fso 判断文件扩展名，供参考

zhulx_wx

liulang0808 发表于 2015-9-23 14:22
http://club.excelhome.net/thread-1165866-1-1.html
fso 判断文件扩展名，供参考

谢谢指点方向!

感觉压力山大啊!
GetObject和SQL都没有弄明白呢,
现在又要弄fso啦!
希望能整个明白.

liulang0808

zhulx_wx 发表于 2015-9-23 14:48
谢谢指点方向!

感觉压力山大啊!

里面有实例，看看就知道了，简单修改就能满足需求。。。。

zhaogang1960

请参考：

1. Sub ado联合查询()
   
2.     Dim cnn As Object, SQL$, f$, p$, m%
   
3.     Set cnn = CreateObject("adodb.connection")
   
4.     p = ThisWorkbook.Path & ""
   
5.     f = Dir(p & "*.xls")
   
6.     While f <> ""
   
7.         If f <> ThisWorkbook.Name Then
   
8.             m = m + 1
   
9.             If m = 1 Then
   
10.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=excel 8.0;Data Source=" & p & f
    
11.                 SQL = "select * from [工作表目录$]"
    
12.             Else
    
13.                 SQL = SQL & " union all select * from [Excel 8.0;Database=" & p & f & "].[工作表目录$] "
    
14.             End If
    
15.         End If
    
16.         f = Dir()
    
17.     Wend
    
18.     [a1].CurrentRegion.Offset(1).ClearContents
    
19.     [a2].CopyFromRecordset cnn.Execute(SQL)
    
20.     cnn.Close
    
21.     Set cnn = Nothing
    
22. End Sub
    

复制代码

zhaogang1960

请注意：
1、每个文件的工作表名都是“工作表目录”
2、待合并的工作簿不超过49个
否则程序需要修改，请测试附件
遍历xls文件的操作.rar (31.17 KB, 下载次数: 133)

2015-9-23 15:11 上传

点击文件名下载附件

zhouzhongchi

1. Sub test()
   
2.     Set Cnn = CreateObject("adodb.connection")
   
3.     Filename = Dir(ThisWorkbook.Path & "\*随件单.xls")
   
4.     Do While Filename <> ""
   
5.         Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=yes;imex=1';Data Source=" & ThisWorkbook.Path & "" & Filename '03版
   
6. '        Cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 8.0;hdr=yes;imex=1';Data Source=" & ThisWorkbook.Path & "" & Filename
   
7.         Sql = "select * from [工作表目录$]"
   
8.         Sheets("统计表").[a65536].End(3).Offset(1).CopyFromRecordset Cnn.Execute(Sql)
   
9.         Cnn.Close
   
10.         Filename = Dir
    
11.     Loop
    
12.     Set Cnn = Nothing
    
13. End Sub

复制代码

zhenghui13

具体你要看一下FSO，里面有一遍就是介绍遍历文件夹的。具体地址有点忘了。

1. '内容参考至EXCELHOME
   
2. Public fso As Object
   
3. Public ff   'FILE FOLDER
   
4. Public f    'FILE
   
5. Public fsd  'FILE SUBFOLDER
   
6. Public wb As Workbook, sht As Worksheet
   
7. Public n As Long, arrOut
   
8. Sub FSO_20150923()
   
9. ReDim arrOut(0 To 1000, 0 To 11)     'Need Consider if >65536
   
10. arrOut(0, 0) = "工作表": arrOut(0, 1) = "序号": arrOut(0, 2) = "目录"
    
11. arrOut(0, 3) = "圆片名称": arrOut(0, 4) = "卡号": arrOut(0, 5) = "总片数":
    
12. arrOut(0, 6) = "余片": arrOut(0, 7) = "可出库料": arrOut(0, 8) = "未测片"
    
13. arrOut(0, 9) = "批次良率": arrOut(0, 10) = "来料日期": arrOut(0, 11) = "测试日期"
    
14. Sheets("统计表").UsedRange.ClearContents
    
15.     GetFolder (ThisWorkbook.Path)
    
16. Sheets("统计表").[A1].Resize(UBound(arrOut) + 1, UBound(arrOut, 2) + 1) = arrOut
    
17. End Sub
    
18. 
    
19. Sub GetFolder(ByVal pth)
    
20. Dim arr
    
21.     Set fso = CreateObject("scripting.filesystemobject")
    
22.     Set ff = fso.GetFolder(pth)
    
23.     For Each f In ff.Files
    
24.         If InStr(Split(f.Name, ".")(UBound(Split(f.Name, "."))), "xl") > 0 Then
    
25.             If Not f.Name = ThisWorkbook.Name Then
    
26.                Set wb = Workbooks.Open(f)
    
27.                For Each sht In wb.Sheets
    
28.                    arr = sht.UsedRange
    
29.                    ReadinOut (arr)
    
30.                Next sht
    
31.                wb.Close False
    
32.             End If
    
33.         End If
    
34.     Next f
    
35.     For Each fsd In ff.subfolders
    
36.         GetFolder (fsd)
    
37.     Next fsd
    
38. End Sub
    
39. 
    
40. Sub ReadinOut(arr)
    
41. Dim i As Long, j As Long
    
42. For i = 2 To UBound(arr)
    
43.    If n = 65536 Then Stop
    
44.    n = n + 1
    
45.    arrOut(n, 0) = f.Name & "/" & sht.Name
    
46.    For j = 1 To UBound(arr, 2)
    
47.        arrOut(n, j) = arr(i, j)
    
48.    Next j
    
49. Next i
    
50. End Sub

复制代码

zhulx_wx

太感谢各位了!
每一次提问都能让我学到好多知识!

zhulx_wx

zhaogang1960 发表于 2015-9-23 15:13
请注意：
1、每个文件的工作表名都是“工作表目录”
2、待合并的工作簿不超过49个

谢谢赵老师!