Option Explicit
Sub 双字典法()
Dim MyName, Dic, Did, i, t, F, TT,
MyFileName
Dim objshell
Dim objfolder
Dim lj, ke, sh
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 & "*.*")
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
加载中，请稍候......
喜欢
加载中…