加载中…
个人资料
微博
  • 博客等级：
  • 博客积分：
  • 博客访问：
  • 关注人气：
  • 获赠金笔：0支
  • 赠出金笔：0支
  • 荣誉徽章：
正文 字体大小：大 中 小

VBA遍历文件夹的三种方法

(2019-01-28 01:02:18)
分类： VBA
  1. VBA遍历文件夹常用有三种方法，这三种方法中,filesearch不适合2007和2010版本，而且速度比较慢，递归法速度也慢。只有用DIR加循环的方法，速度飞快。下面是三种方法的代码：  
  2.   
  3.      1、filesearch法  
  4.   
  5. Sub test3()  
  6. Dim wb As Workbook  
  7. Dim i As Long  
  8. Dim t  
  9. t = Timer  
  10.     With Application.FileSearch '调用fileserch对象  
  11.         .NewSearch '开始新的搜索  
  12.         .LookIn = ThisWorkbook.path  '设置搜索的路径  
  13.         .SearchSubFolders = True '搜索范围包括 LookIn 属性指定的文件夹中的所有子文件夹  
  14.         .Filename = "*.xls" '设置搜索的文件类型  
  15.        ' .FileType = msoFileTypeExcelWorkbooks  
  16.         If .Execute() > 0 Then '如果找到文件  
  17.             For i = 1 To .FoundFiles.Count  
  18.                 'On Error Resume Next  
  19.                 Cells(i, 1) = .FoundFiles(i) '把找到的文件放在单元格里  
  20.             Next i  
  21.         Else  
  22.              MsgBox "没找到文件"  
  23.         End If  
  24.      End With  
  25.  MsgBox Timer - t  
  26. End Sub  
  27.   
  28.      2、递归法  
  29.   
  30.        Sub Test()  
  31. Dim iPath As String, i As Long  
  32. Dim t  
  33. t = Timer  
  34.     With Application.FileDialog(msoFileDialogFolderPicker)  
  35.         .Title = "请选择要查找的文件夹"  
  36.         If .Show Then  
  37.             iPath = .SelectedItems(1)  
  38.         End If  
  39.     End With  
  40.       
  41.     If iPath = "False" Or Len(iPath) = 0 Then Exit Sub  
  42.       
  43.     i = 1  
  44.     Call GetFolderFile(iPath, i)  
  45.    MsgBox Timer - t  
  46.     MsgBox "文件名链接获取完毕。", vbOKOnly, "提示"  
  47.     
  48. End Sub  
  49.   
  50. Private Sub GetFolderFile(ByVal nPath As String, ByRef iCount As Long)  
  51. Dim iFileSys  
  52. 'Dim iFile As Files, gFile As File  
  53. 'Dim iFolder As Folder, sFolder As Folders, nFolder As Folder  
  54.      Set iFileSys = CreateObject("Scripting.FileSystemObject")  
  55.     Set iFolder = iFileSys.GetFolder(nPath)  
  56.     Set sFolder = iFolder.SubFolders  
  57.     Set iFile = iFolder.Files  
  58.   
  59.     With ActiveSheet  
  60.         For Each gFile In iFile  
  61.            ' .Hyperlinks.Add anchor:=.Cells(iCount, 1), Address:=gFile.path, TextToDisplay:=gFile.Name  
  62.             iCount = iCount + 1  
  63.         Next  
  64.     End With  
  65.       
  66.     '递归遍历所有子文件夹  
  67.     For Each nFolder In sFolder  
  68.         Call GetFolderFile(nFolder.path, iCount)  
  69.     Next  
  70. End Sub  
  71.   
  72.      3、dir循环法       重点使用这个方法，可以自己选择文件夹
  73.   
  74. Sub Test() '使用双字典，旨在提高速度  
  75.     Dim MyName, Dic, Did, i, t, F, TT, MyFileName  
  76.        'On Error Resume Next  
  77.     Set objShell = CreateObject("Shell.Application")  
  78.     Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)  
  79.     If Not objFolder Is Nothing Then lj = objFolder.self.path & ""  
  80.     Set objFolder = Nothing  
  81.     Set objShell = Nothing  
  82.   
  83.     t = Time  
  84.     Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象  
  85.     Set Did = CreateObject("Scripting.Dictionary")  
  86.     Dic.Add (lj), ""  
  87.     i = 0  
  88.     Do While i < Dic.Count  
  89.         Ke = Dic.keys   '开始遍历字典  
  90.         MyName = Dir(Ke(i), vbDirectory)    '查找目录  
  91.         Do While MyName <> ""  
  92.             If MyName <> "." And MyName <> ".." Then  
  93.                 If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录  
  94.                     Dic.Add (Ke(i) & MyName & ""), ""  '就往字典中添加这个次级目录名作为一个条目  
  95.                 End If  
  96.             End If  
  97.             MyName = Dir    '继续遍历寻找  
  98.         Loop  
  99.         i = i + 1  
  100.     Loop  
  101.     Did.Add ("文件清单"), ""    '以查找D盘下所有EXCEL文件为例  
  102.     For Each Ke In Dic.keys  
  103.         MyFileName = Dir(Ke & "*.xls")  
  104.         Do While MyFileName <> ""  
  105.             Did.Add (Ke & MyFileName), ""  
  106.             MyFileName = Dir  
  107.         Loop  
  108.     Next  
  109.     For Each Sh In ThisWorkbook.Worksheets  
  110.         If Sh.Name = "XLS文件清单" Then  
  111.             Sheets("XLS文件清单").Cells.Delete  
  112.             F = True  
  113.             Exit For  
  114.         Else  
  115.             F = False  
  116.         End If  
  117.     Next  
  118.     If Not F Then  
  119.         Sheets.Add.Name = "XLS文件清单"  
  120.     End If  
  121.     Sheets("XLS文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)  
  122.     TT = Time - t  
  123.     MsgBox Minute(TT) & "分" & Second(TT) & "秒"  
  124. End Sub  

喜欢

0

阅读┊ 收藏 ┊ 喜欢▼ ┊打印┊举报/Report
  

新浪BLOG意见反馈留言板　欢迎批评指正

新浪简介 | About Sina | 广告服务 | 联系我们 | 招聘信息 | 网站律师 | SINA English | 产品答疑

Copyright © 1996 - 2022 SINA Corporation, All Rights Reserved

新浪公司 版权所有