获取指定文件夹下多层xls文件

文件需要放在PMC相关资料文件夹内

Sub Test()

Dim MyName, Dic, Did, I, T, F, TT, MyFileName

T = Time

Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象

Set Did = CreateObject("Scripting.Dictionary")

Dic.Add ("F:\PMC相关资料\"), ""

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盘My Documents下所有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

(0)

相关推荐