|
Dim ArrFiles(1 To 10000) '创建一个数组空间,用来存放文件名称
Dim cntFiles% '文件个数
'引用FileSystemObject对象
'注意:要使用FileSystemObject对象,
'需要首先引用一下,具体方法,VBE--工具--引用--找到miscrosoft scription runtime项目并选中
Sub ListAllFiles()
'Call 通过GUID_自动添加_引用_MicrosoftScriptingRuntime
On Error Resume Next
Dim strPath$ '声明文件路径
Dim j%
Dim arr(1 To 500, 1 To 70)
'Set fso = CreateObject("Scripting.FileSystemObject")
Dim fso As New filesystemobject, fd As Folder '创建一个FileSystemObject对象和一个文件夹对象
strPath = ThisWorkbook.Path & "\" '"设置要遍历的文件夹目录
cntFiles = 0
Set fd = fso.GetFolder(strPath) '设置fd文件夹对象
SearchFiles fd '调用子程序查搜索文件
'' For j = 1 To cntFiles
'' '下面可以装入自己想要对所有提取文件进行操作的代码
'' '================================================
'' If ArrFiles(j) Like "*.xls" Or ArrFiles(j) Like "*.xlsx" And ArrFiles(j) <> strPath & ThisWorkbook.Name Then
'' Set wb = Workbooks.Open(ArrFiles(j))
'' With wb
''
'' With .Sheets(1)
'' arr(j, 1) = .Range("D1")
'' arr(j, 2) = .Range("J1")
'' arr(j, 3) = .Range("O1")
'' arr(j, 4) = .Range("E7")
'' arr(j, 5) = .Range("E8")
'' arr(j, 6) = .Range("E9")
'' arr(j, 7) = .Range("E10")
'' arr(j, 8) = .Range("E11")
'' arr(j, 9) = .Range("E12")
'' arr(j, 10) = .Range("E13")
'' arr(j, 11) = .Range("M7")
'' arr(j, 12) = .Range("M8")
'' arr(j, 13) = .Range("M9")
'' arr(j, 14) = .Range("M10")
'' arr(j, 15) = .Range("M11")
'' arr(j, 16) = .Range("M12")
'' arr(j, 17) = .Range("B7")
'' arr(j, 18) = .Range("B8")
'' arr(j, 19) = .Range("B9")
'' arr(j, 20) = .Range("B10")
'' arr(j, 21) = .Range("B11")
'' arr(j, 22) = .Range("B12")
'' arr(j, 23) = .Range("B13")
'' arr(j, 24) = .Range("J7")
'' arr(j, 25) = .Range("J8")
'' arr(j, 26) = .Range("J9")
'' arr(j, 27) = .Range("J10")
'' arr(j, 28) = .Range("J11")
'' arr(j, 29) = .Range("J12")
'' arr(j, 30) = .Range("J15")
'' arr(j, 31) = .Range("J16")
'' arr(j, 32) = .Range("J17")
'' arr(j, 33) = .Range("J18")
'' arr(j, 34) = .Range("J19")
'' arr(j, 35) = .Range("J20")
'' arr(j, 36) = .Range("J21")
'' arr(j, 37) = .Range("J22")
'' arr(j, 38) = .Range("J23")
'' arr(j, 39) = .Range("J24")
'' arr(j, 40) = .Range("J25")
'' arr(j, 41) = .Range("J26")
'' arr(j, 42) = .Range("J27")
'' arr(j, 43) = .Range("J28")
'' arr(j, 44) = .Range("J29")
'' arr(j, 45) = .Range("J30")
'' arr(j, 46) = .Range("J31")
'' arr(j, 47) = .Range("J32")
'' arr(j, 48) = .Range("J33")
'' arr(j, 49) = .Range("J34")
'' arr(j, 50) = .Range("C15")
'' arr(j, 51) = .Range("C16")
'' arr(j, 52) = .Range("C17")
'' arr(j, 53) = .Range("C18")
'' arr(j, 54) = .Range("C19")
'' arr(j, 55) = .Range("C20")
'' arr(j, 56) = .Range("C21")
'' arr(j, 57) = .Range("C22")
'' arr(j, 58) = .Range("C23")
'' arr(j, 59) = .Range("C24")
'' arr(j, 60) = .Range("C25")
'' arr(j, 61) = .Range("C26")
'' arr(j, 62) = .Range("C27")
'' arr(j, 63) = .Range("C28")
'' arr(j, 64) = .Range("C29")
'' arr(j, 65) = .Range("C30")
'' arr(j, 66) = .Range("C31")
'' arr(j, 67) = .Range("C32")
'' arr(j, 68) = .Range("C33")
'' arr(j, 69) = .Range("C34")
'' End With
'' arr(j, 70) = .Name
'' .Close False
'' End With
'' [a2].Resize(5000, 70).ClearContents
'' [a2].Resize(5000, 70).Borders.LineStyle = xlNone
'' [a2].Resize(j, 70) = arr
'' [a2].Resize(j, 70).Borders.LineStyle = 1
''
'' Set wb = Nothing
'' '================================================
'' End If
'' Next j
Sheets(1).Range("A1").Resize(cntFiles) = Application.Transpose(ArrFiles) '把数组内的路径和文件名放在单元格中
End Sub
Sub SearchFiles(ByVal fd As Folder)
Dim fl As file
Dim sfd As Folder
For Each fl In fd.Files '通过循环把文件逐个放在数组内
If fl <> ThisWorkbook.FullName And InStr(fl, "~$") = 0 Then
cntFiles = cntFiles + 1
' ArrFiles(cntFiles) = fl.Path
ArrFiles(cntFiles) = Split(fl.Name, ".t")(0)
End If
Next fl
If fd.SubFolders.Count = 0 Then Exit Sub 'SubFolders返回由指定文件夹中所有子文件夹(包括隐藏文件夹和系统文件夹)组成的 Folders 集合
For Each sfd In fd.SubFolders '在 Folders 集合进行循环查找
SearchFiles sfd '使用递归方法查找下一个文件夹
Next
End Sub |
|