彰化一整天的論壇

 找回密碼
 立即註冊
搜索
查看: 195|回復: 0

如何用VBA遍历指定目录下的所有子文件夹和文件

[複製鏈接]
發表於 2016-11-4 16:15:16 | 顯示全部樓層 |閱讀模式

  1. Sub Test() '使用双字典,旨在提高速度
  2.     Dim MyName, Dic, Did, I, T, F, TT, MyFileName
  3.     T = Time
  4.     Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
  5.     Set Did = CreateObject("Scripting.Dictionary")
  6.     Dic.Add ("D:\"), ""
  7.     I = 0
  8.     Do While I < Dic.Count
  9.         Ke = Dic.keys   '开始遍历字典
  10.         MyName = Dir(Ke(I), vbDirectory)    '查找目录
  11.         Do While MyName <> ""
  12.             If MyName <> "." And MyName <> ".." Then
  13.                 If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
  14.                     Dic.Add (Ke(I) & MyName & "\"), ""  '就往字典中添加这个次级目录名作为一个条目
  15.                 End If
  16.             End If
  17.             MyName = Dir    '继续遍历寻找
  18.         Loop
  19.         I = I + 1
  20.     Loop
  21.     Did.Add ("文件清单"), ""    '以查找D盘下所有EXCEL文件为例
  22.     For Each Ke In Dic.keys
  23.         MyFileName = Dir(Ke & "*.xls")
  24.         Do While MyFileName <> ""
  25.             Did.Add (Ke & MyFileName), ""
  26.             MyFileName = Dir
  27.         Loop
  28.     Next
  29.     For Each Sh In ThisWorkbook.Worksheets
  30.         If Sh.Name = "XLS文件清单" Then
  31.             Sheets("XLS文件清单").Cells.Delete
  32.             F = True
  33.             Exit For
  34.         Else
  35.             F = False
  36.         End If
  37.     Next
  38.     If Not F Then
  39.         Sheets.Add.Name = "XLS文件清单"
  40.     End If
  41.     Sheets("XLS文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
  42.     TT = Time - T
  43.     MsgBox Minute(TT) & "分" & Second(TT) & "秒"
  44. End Sub
複製代碼
文章來源: http://club.excelhome.net/thread-355569-1-1.html
回復

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

 ㄚ母滴雞湯
 員林香純滴雞精

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)  |网站地图

GMT+8, 2018-1-17 01:39 , Processed in 0.027038 second(s), 10 queries , Apc On.

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回復 返回頂部 返回列表