本代码可以在指定文件夹及其所有子文件夹中,查找全部指定类型的文件(如 *.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
联系客服