- <span style="font-size:14px;">VBA遍历文件夹常用有三种方法,这三种方法中,filesearch不适合2007和2010版本,而且速度比较慢,递归法速度也慢。只有用DIR加循环的方法,速度飞快。下面是三种方法的代码:
- 1、filesearch法
- Sub test3()
- Dim wb As Workbook
- Dim i As Long
- Dim t
- t = Timer
- With Application.FileSearch '调用fileserch对象
- .NewSearch '开始新的搜索
- .LookIn = ThisWorkbook.path '设置搜索的路径
- .SearchSubFolders = True '搜索范围包括 LookIn 属性指定的文件夹中的所有子文件夹
- .Filename = "*.xls" '设置搜索的文件类型
- ' .FileType = msoFileTypeExcelWorkbooks
- If .Execute() > 0 Then '如果找到文件
- For i = 1 To .FoundFiles.Count
- 'On Error Resume Next
- Cells(i, 1) = .FoundFiles(i) '把找到的文件放在单元格里
- Next i
- Else
- MsgBox "没找到文件"
- End If
- End With
- MsgBox Timer - t
- End Sub
- 2、递归法
- Sub Test()
- Dim iPath As String, i As Long
- Dim t
- t = Timer
- With Application.FileDialog(msoFileDialogFolderPicker)
- .Title = "请选择要查找的文件夹"
- If .Show Then
- iPath = .SelectedItems(1)
- End If
- End With
- If iPath = "False" Or Len(iPath) = 0 Then Exit Sub
- i = 1
- Call GetFolderFile(iPath, i)
- MsgBox Timer - t
- MsgBox "文件名链接获取完毕。", vbOKOnly, "提示"
- End Sub
- Private Sub GetFolderFile(ByVal nPath As String, ByRef iCount As Long)
- Dim iFileSys
- 'Dim iFile As Files, gFile As File
- 'Dim iFolder As Folder, sFolder As Folders, nFolder As Folder
- Set iFileSys = CreateObject("Scripting.FileSystemObject")
- Set iFolder = iFileSys.GetFolder(nPath)
- Set sFolder = iFolder.SubFolders
- Set iFile = iFolder.Files
- With ActiveSheet
- For Each gFile In iFile
- ' .Hyperlinks.Add anchor:=.Cells(iCount, 1), Address:=gFile.path, TextToDisplay:=gFile.Name
- iCount = iCount + 1
- Next
- End With
- '递归遍历所有子文件夹
- For Each nFolder In sFolder
- Call GetFolderFile(nFolder.path, iCount)
- Next
- End Sub
- 3、dir循环法
- Sub Test() '使用双字典,旨在提高速度
- Dim MyName, Dic, Did, i, t, F, TT, MyFileName
- 'On Error Resume Next
- Set objShell = CreateObject("Shell.Application")
- Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)
- If Not objFolder Is Nothing Then lj = objFolder.self.path & "\"
- Set objFolder = Nothing
- Set objShell = Nothing
- t = Time
- Set Dic = CreateObject("Scripting.Dictionary") '创建一个字典对象
- Set Did = CreateObject("Scripting.Dictionary")
- Dic.Add (lj), ""
- i = 0
- Do While i < Dic.Count
- Ke = Dic.keys '开始遍历字典
- MyName = Dir(Ke(i), vbDirectory) '查找目录
- Do While MyName <> ""
- If MyName <> "." And MyName <> ".." Then
- If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录
- Dic.Add (Ke(i) & MyName & "\"), "" '就往字典中添加这个次级目录名作为一个条目
- End If
- End If
- MyName = Dir '继续遍历寻找
- Loop
- i = i + 1
- Loop
- Did.Add ("文件清单"), "" '以查找D盘下所有EXCEL文件为例
- For Each Ke In Dic.keys
- MyFileName = Dir(Ke & "*.xls")
- Do While MyFileName <> ""
- Did.Add (Ke & MyFileName), ""
- MyFileName = Dir
- Loop
- Next
- For Each Sh In ThisWorkbook.Worksheets
- If Sh.Name = "XLS文件清单" Then
- Sheets("XLS文件清单").Cells.Delete
- F = True
- Exit For
- Else
- F = False
- End If
- Next
- If Not F Then
- Sheets.Add.Name = "XLS文件清单"
- End If
- Sheets("XLS文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
- TT = Time - t
- MsgBox Minute(TT) & "分" & Second(TT) & "秒"
- End Sub
- </span>
VBA遍历文件夹的三种方法(转载)
最新推荐文章于 2024-08-10 14:59:16 发布