ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 15153|回复: 70

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2016-12-24 10:40 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:文件操作和FSO
附件中有二个程序,一个是搜索目录,另一个是搜索文件的,都是采取树形加栈的结构的非递归程序,速度远超一般的递归程序,且经测试即使有数万个文件也不会卡死,现作新年礼物以献大家,祈求来年好运。


评分

3

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-12-24 10:41 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
附件在此:

文件搜索1.zip

9.34 KB, 下载次数: 866

评分

15

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-12-24 10:43 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
Sub mlSearchFDG(ByRef mlNameArr() As String, pPath As String, pSub As Boolean)  '搜索子目录
'mlNameArr装文件名动态数组,psb子目录开关,pPath搜索起始路径
    On Error Resume Next
    Dim DirFile, mf&, pPath1$
    Dim workStack$(), top&    'workstack工作栈,top栈顶变量
    pPath = Trim(pPath)
    If Right(pPath, 1) <> "\" Then pPath = pPath & "\"    ' 对搜索路径加 backslash(反斜线)
    pPath1 = pPath
    top = 1
    ReDim Preserve workStack(0 To top)
    Do While top >= 1
        DirFile = Dir(pPath1, vbDirectory)
        Do While DirFile <> ""
            If DirFile <> "." And DirFile <> ".." Then
                If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
                    mf = mf + 1
                    ReDim Preserve mlNameArr(1 To mf)
                    mlNameArr(mf) = pPath1 & DirFile
                End If
            End If
            DirFile = Dir
        Loop
        If pSub = False Then Exit Sub
        DirFile = Dir(pPath1, vbDirectory)    ' 搜索子目录
        Do While DirFile <> ""
            If DirFile <> "." And DirFile <> ".." Then
                If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
                    workStack(top) = pPath1 & DirFile & "\"    '压栈
                    top = top + 1
                    If top > UBound(workStack) Then ReDim Preserve workStack(0 To top)
                End If
            End If
            DirFile = Dir
        Loop
        If top > 0 Then pPath1 = workStack(top - 1): top = top - 1    '弹栈
    Loop
    Erase workStack
End Sub

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-12-24 10:44 | 显示全部楼层
  1. Sub FileSearchFDG(ByRef fileNameArr() As String, pPath As String, pMask As String, pSub As Boolean)
  2.     'fileNameArr装文件名动态数组,psb子目录开关,pPath搜索起始路径,pMask扩展名(如doc)
  3.     On Error Resume Next
  4.     Dim DirFile, mf&, pPath1$
  5.     Dim workStack$(), top&    'workstack工作栈,top栈顶变量
  6.     pPath = Trim(pPath)
  7.     If Right(pPath, 1) <> "" Then pPath = pPath & ""    ' 对搜索路径加 backslash(反斜线)
  8.     pPath1 = pPath
  9.     top = 1
  10.     ReDim Preserve workStack(0 To top)
  11.     Do While top >= 1
  12.         DirFile = Dir(pPath1 & "*." & pMask)
  13.         Do While DirFile <> ""
  14.             mf = mf + 1
  15.             ReDim Preserve fileNameArr(1 To mf)
  16.             fileNameArr(mf) = pPath1 & DirFile
  17.             DirFile = Dir
  18.         Loop
  19.         If pSub = False Then Exit Sub
  20.         DirFile = Dir(pPath1, vbDirectory)    ' 搜索子目录
  21.         Do While DirFile <> ""
  22.             If DirFile <> "." And DirFile <> ".." Then
  23.                 If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
  24.                     workStack(top) = pPath1 & DirFile & ""    '压栈
  25.                     top = top + 1
  26.                     If top > UBound(workStack) Then ReDim Preserve workStack(0 To top)
  27.                 End If
  28.             End If
  29.             DirFile = Dir    'next file
  30.         Loop
  31.         If top > 0 Then pPath1 = workStack(top - 1): top = top - 1    '弹栈
  32.     Loop
  33.     Erase workStack
  34. End Sub
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-12-24 10:46 | 显示全部楼层
使用方法:
  1. Sub aa()
  2.     Dim arr() As String, mf&
  3.     Range("A1").Resize(Range("a1").End(xlDown).Row, 1).Clear
  4.     mlSearchFDG arr, "F:", True '搜索子目录
  5.     Range("a1").Resize(UBound(arr), 1) = Application.Transpose(arr)
  6.    
  7.     FileSearchFDG arr, "F:", "*", True '搜索全部文件
  8.     Range("d1").Resize(UBound(arr), 1) = Application.Transpose(arr)
  9.    
  10.     FileSearchFDG arr, "F:", "xls", True '搜索特定文件
  11.     Range("g1").Resize(UBound(arr), 1) = Application.Transpose(arr)
  12.     Erase arr
  13. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2016-12-24 14:23 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2016-12-24 14:36 | 显示全部楼层
本帖最后由 百度不到去谷歌 于 2016-12-24 14:42 编辑

大神作品 严重支持 下载的人多回帖吧 拿了人家东西起码说声谢谢
ps 经测试 速度确实爆快!

TA的精华主题

TA的得分主题

发表于 2016-12-24 17:38 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2016-12-24 20:49 | 显示全部楼层
看到楼主说“栈”,我吓了跳,再一看,原来所谓的“栈”只是动态数组,不过,思路确实很好,点赞

TA的精华主题

TA的得分主题

发表于 2016-12-24 21:37 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 22:21 , Processed in 0.055616 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表