新年献礼：最快文件搜索程序

wzsy2_mrf · 发表于 2019-2-13 18:26

ivccav 发表于 2019-1-5 13:04
思路是好，说效率远超递归，吹得过头了。。我用递归法，9秒获得17281个文件。

第一次用楼主他的代码 ...

你用错了，递归与用栈效率是不可比的，这是常识，之所以常用递归不过是方便且思路清晰。

ivccav · 发表于 2019-2-13 19:20

wzsy2_mrf 发表于 2019-2-13 18:26
你用错了，递归与用栈效率是不可比的，这是常识，之所以常用递归不过是方便且思路清晰。

然鹅，我一个字母都没有修改，只改了目标路径，

直接使用楼主的使用示例代码，却是错误的结果。

wzsy2_mrf · 发表于 2019-2-13 19:24

你不会仔细一点吗？你用了搜索子文件夹的过程，不是搜索文件的过程!如果有错，其他人早发现了。

gwjkkkkk · 发表于 2019-12-24 18:44

速度确实爆快！试用。

opel-wong · 发表于 2019-12-24 22:36

好贴，关注一下，留个记号。

夜风窗台 · 发表于 2020-1-9 21:04

很赞很好用

云中之海 · 发表于 2020-11-12 01:36

我改成自定义函数,使用的是字典与集合.

'改用collection形式,让弹栈更易于理解,比数组的优点是有一个明显弹栈动作,栈会变空
Public Function vFileSearch1(pPath As String, Optional pMask As String = "", Optional pSub As Boolean = True) As Variant
'psb子目录开关,pPath搜索起始路径，pMask如果要必填写,那得这样填写"*.xlsx",加星号
Dim DirFile, mf As Long, pPath1 As String, workStack As Collection, fileNameDic As Variant 'workstack工作栈,
On Error Resume Next
Set workStack = New Collection
Set fileNameDic = CreateObject("scripting.dictionary")
pPath = Trim(pPath)
If Right(pPath, 1) <> Application.PathSeparator Then pPath = pPath & Application.PathSeparator
pPath1 = pPath
Do Until workStack Is Nothing
DirFile = Dir(pPath1 & pMask)
Do While DirFile <> ""
fileNameDic.Add pPath1 & DirFile, pPath1 & DirFile
DirFile = Dir
Loop
If pSub = False Then Exit Function
DirFile = Dir(pPath1, vbDirectory)
Do While DirFile <> ""
If DirFile <> "." And DirFile <> ".." Then
If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
workStack.Add pPath1 & DirFile & Application.PathSeparator, pPath1 & DirFile & Application.PathSeparator
End If
End If
DirFile = Dir
Loop
If workStack.Count > 0 Then
pPath1 = workStack(workStack.Count)
workStack.Remove (workStack.Count)
Else
Set workStack = Nothing
End If
Loop
vFileSearch1 = WorksheetFunction.Transpose(fileNameDic.keys)
End Function

复制代码

云中之海 · 发表于 2020-11-12 01:37

'改用collection形式,让弹栈更易于理解,比数组的优点是有一个明显弹栈动作,栈会变空
Public Function vFileSearch1(pPath As String, Optional pMask As String = "", Optional pSub As Boolean = True) As Variant
'psb子目录开关,pPath搜索起始路径，pMask如果要必填写,那得这样填写"*.xlsx",加星号
Dim DirFile, mf As Long, pPath1 As String, workStack As Collection, fileNameDic As Variant 'workstack工作栈,
On Error Resume Next
Set workStack = New Collection
Set fileNameDic = CreateObject("scripting.dictionary")
pPath = Trim(pPath)
If Right(pPath, 1) <> Application.PathSeparator Then pPath = pPath & Application.PathSeparator
pPath1 = pPath
Do Until workStack Is Nothing
DirFile = Dir(pPath1 & pMask)
Do While DirFile <> ""
fileNameDic.Add pPath1 & DirFile, pPath1 & DirFile
DirFile = Dir
Loop
If pSub = False Then Exit Function
DirFile = Dir(pPath1, vbDirectory)
Do While DirFile <> ""
If DirFile <> "." And DirFile <> ".." Then
If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
workStack.Add pPath1 & DirFile & Application.PathSeparator, pPath1 & DirFile & Application.PathSeparator
End If
End If
DirFile = Dir
Loop
If workStack.Count > 0 Then
pPath1 = workStack(workStack.Count)
workStack.Remove (workStack.Count)
Else
Set workStack = Nothing
End If
Loop
vFileSearch1 = WorksheetFunction.Transpose(fileNameDic.keys)
End Function

复制代码

云中之海 · 发表于 2020-11-12 01:39

改成自定义函数,大家试试

'改用collection形式,让弹栈更易于理解,比数组的优点是有一个明显弹栈动作,栈会变空
Public Function vFileSearch1(pPath As String, Optional pMask As String = "", Optional pSub As Boolean = True) As Variant
'psb子目录开关,pPath搜索起始路径，pMask如果要必填写,那得这样填写"*.xlsx",加星号
Dim DirFile, mf As Long, pPath1 As String, workStack As Collection, fileNameDic As Variant 'workstack工作栈,
On Error Resume Next
Set workStack = New Collection
Set fileNameDic = CreateObject("scripting.dictionary")
pPath = Trim(pPath)
If Right(pPath, 1) <> Application.PathSeparator Then pPath = pPath & Application.PathSeparator
pPath1 = pPath
Do Until workStack Is Nothing
DirFile = Dir(pPath1 & pMask)
Do While DirFile <> ""
fileNameDic.Add pPath1 & DirFile, pPath1 & DirFile
DirFile = Dir
Loop
If pSub = False Then Exit Function
DirFile = Dir(pPath1, vbDirectory)
Do While DirFile <> ""
If DirFile <> "." And DirFile <> ".." Then
If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
workStack.Add pPath1 & DirFile & Application.PathSeparator, pPath1 & DirFile & Application.PathSeparator
End If
End If
DirFile = Dir
Loop
If workStack.Count > 0 Then
pPath1 = workStack(workStack.Count)
workStack.Remove (workStack.Count)
Else
Set workStack = Nothing
End If
Loop
vFileSearch1 = WorksheetFunction.Transpose(fileNameDic.keys)
End Function

复制代码

gaolzhen · 发表于 2020-11-19 23:47

收藏了，谢谢！

		自动登录	找回密码
密码			免费注册

[原创] 新年献礼：最快文件搜索程序