|
本代码可以在指定文件夹及其所有子文件夹中，查找全部指定类型的文件（如 *.xls*），或者与指定类型匹配的文件（如
????.xls），也可以查找单个文件（如 ABC.doc、ABC.txt）。
代码来自ExcelHome网站，本人收录时作了部分修改。经测试，查找D:\所有Excel文件与运行DOS命令：
dir d:\*.xls* /s/b/a-d>d:\1.txt
start
d:\1.txt
结果一致。
代码如下：
Sub
FindAllFiles()
'在指定文件夹及其所有子文件夹中，查找全部指定类型的文件（如
*.xls*），
'或者与指定类型匹配的文件（如
????.xls），也可以查找单个文件（如 ABC.doc）。
Dim sFolder As
String, PathDic As Object,
FileDic As Object, ErrDic As Object,
_
I As Long, iTime As
Single, bHave As Boolean,
sFileName As String, _
sMyPath As String,
sMyType As String, objShell, objFolde, Arr, tmpPath, SH,
_
bErrList As Boolean
Set objShell =
CreateObject("Shell.Application")
Set
objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)
If objFolder Is Nothing
Then
Exit Sub
Else
sMyPath =
objFolder.self.Path
If
Right(sMyPath, 1) <> "\" Then
sMyPath = sMyPath &
"\"
End If
End
If
sMyType =
InputBox("请输入查找文件类型或单个文件名称：" & vbCrLf & vbCrLf &
_
"比如：*.xls* 、*.doc 、ABC.xls 、?????.*", "文件类型或单个文件",
"*.xls*")
If sMyType = "" Then
Exit Sub
End
If
Set objFolder = Nothing
Set objShell = Nothing
bErrList = False '如果要显示出错文件夹，请把值改为
True
Application.StatusBar = "正在查找，请等待..."
iTime =
Timer
Set PathDic =
CreateObject("Scripting.Dictionary")
Set FileDic =
CreateObject("Scripting.Dictionary")
Set ErrDic =
CreateObject("Scripting.Dictionary")
ErrDic.Add "出错文件夹",
""
PathDic.Add sMyPath, ""
'有些文件夹会出错，但这个文件夹中的相应文件仍能找出来
On Error Resume Next
I = 0
Do While I
< PathDic.Count
Arr = PathDic.keys
sFolder =
Dir(Arr(I), vbDirectory)
Do While sFolder <> ""
'排除掉当前目录(.)和父目录(..)
If sFolder <> "." And sFolder <> ".."
Then
'有些文件夹这里会出错
'如果是次级目录
If (GetAttr(Arr(I) & sFolder) And vbDirectory)
= vbDirectory Then
If Err.Number <> 0 Then
Err.Clear
If bErrList Then
ErrDic.Add
(Arr(I) & sFolderr), ""
'Err.Clear '放在这里会导致查找结果不全
End If
Else
PathDic.Add
(Arr(I) & sFolder & "\"), ""
End If
End If
End If
sFolder = Dir
Loop
I = I + 1
Loop
On Error GoTo 0
FileDic.Add ("文件清单【文件夹“" &
sMyPath & "”及其所有子文件夹中“" & sMyType & "”】"), ""
For Each
tmpPath In PathDic.keys
sFileName
= Dir(tmpPath & sMyType)
Do
While sFileName <>
""
'如果查找文件类型类似?????.*，必须加下面这行代码
'If sFileName Like sMyType Then
'文件名及扩展名区分大小写(如*.xls与*.XLS不能同时查出来)
If UCase(sFileName) Like UCase(sMyType) Then '文件名及扩展名不区分大小写
FileDic.Add
(tmpPath & sFileName), ""
End If
sFileName = Dir
Loop
Next
For Each SH
In ThisWorkbook.Worksheets
If SH.Name = "查找结果" Then
Sheets("查找结果").Cells.ClearContents
bHave
= True
Exit For
End If
Next
If
Not bHave Then
Sheets.Add.Name =
"查找结果"
End If
I = 1
If bErrList And ErrDic.Count > 1 Then
Sheets("查找结果").[A1].Resize(ErrDic.Count,
1) = WorksheetFunction.Transpose(ErrDic.keys)
I = ErrDic.Count +
2
End If
Sheets("查找结果").Range("A" &
I).Resize(FileDic.Count, 1) =
WorksheetFunction.Transpose(FileDic.keys)
Sheets("查找结果").Select
Sheets("查找结果").[A1].Select
iTime
= Timer - iTime
Application.StatusBar = False
MsgBox "查找结束，用时" & Round(iTime,
0) & "秒。"
End Sub
|
