ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 挑战你的Excel知识,一起测验下 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 12287|回复: 74

递归 搜索文件(搜索目录及子目录)

[复制链接]

TA的精华主题

TA的得分主题

发表于 2008-5-28 17:24 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:递归

Public arr1, y%
Sub peng()
    ReDim arr1(1 To 65536, 1 To 1)
    y = 0
    Call xi("*", ActiveWorkbook.Path)
    Cells(1, 1).Resize(y, 1) = arr1
End Sub

'a查询文件条件设置
'pt路径设置

Sub xi(a, pt)
  On Error GoTo ren
    Dim x%, i%
    Dim d As New Dictionary
    dirs = Dir(pt & "\" & a)
    Do While dirs <> ""
        y = y + 1
        d(dirs) = ""
        arr1(y, 1) = pt & "\" & dirs
        dirs = Dir
    Loop
    ReDim arr(1 To 100)
    dirs = Dir(pt & "\", vbDirectory)
    Do While dirs <> ""
        If dirs <> "." And dirs <> ".." And Not d.Exists(dirs) Then
            x = x + 1
            If x > UBound(arr) Then ReDim Preserve arr(1 To UBound(arr) + 100)
            arr(x) = pt & "\" & dirs
        End If
        dirs = Dir
    Loop
    For i = 1 To UBound(arr)
        If arr(i) = "" Then Exit Sub
        Call xi(a, arr(i))
    Next i
ren:
End Sub

对速度进行了优化.



[此贴子已经被作者于2008-5-29 8:44:04编辑过]

TA的精华主题

TA的得分主题

发表于 2008-5-28 21:35 | 显示全部楼层
支持。看楼主的帖子很受启发

TA的精华主题

TA的得分主题

 楼主| 发表于 2008-5-29 08:42 | 显示全部楼层

多谢支持,不过此功能确实不实用.

[此贴子已经被作者于2008-5-29 8:57:06编辑过]

TA的精华主题

TA的得分主题

发表于 2008-5-29 08:56 | 显示全部楼层
Dim d As New Dictionary这句说定义出错,可否改为本:Set d = CreateObject("Scripting.Dictionary") ?

TA的精华主题

TA的得分主题

 楼主| 发表于 2008-5-29 08:58 | 显示全部楼层
QUOTE:
以下是引用只观看在2008-5-29 8:56:44的发言:
Dim d As New Dictionary这句说定义出错,可否改为本:Set d = CreateObject("Scripting.Dictionary") ?

当然可以

前期还要引用字典

TA的精华主题

TA的得分主题

发表于 2008-5-29 09:16 | 显示全部楼层

Function GAF(newpath)
 On Error Resume Next
  Set fs = CreateObject("Scripting.FileSystemObject")
 Set f = fs.GetFolder(newpath)
 Set fc = f.Files
 For Each fl In fc
  此段处理事情 

 Next
        err.clear
 Set fc1 = f.subfolders
 For Each fl1 In fc1
          GAF(fl1.path)
        next
        err.clear
        set fc=nothing
 set f=nothing
 set fs=nothing
        set fc1=nothing
        err.clear
End Function

这个是我平时用的。

TA的精华主题

TA的得分主题

 楼主| 发表于 2008-5-29 09:34 | 显示全部楼层
QUOTE:
以下是引用realsoar在2008-5-29 9:16:13的发言:

Function GAF(newpath)
 On Error Resume Next
  Set fs = CreateObject("Scripting.FileSystemObject")
 Set f = fs.GetFolder(newpath)
 Set fc = f.Files
 For Each fl In fc
  此段处理事情 

 Next
        err.clear
 Set fc1 = f.subfolders
 For Each fl1 In fc1
          GAF(fl1.path)
        next
        err.clear
        set fc=nothing
 set f=nothing
 set fs=nothing
        set fc1=nothing
        err.clear
End Function

这个是我平时用的。

你这代码不错,学习了

TA的精华主题

TA的得分主题

发表于 2008-5-29 18:16 | 显示全部楼层
QUOTE:
以下是引用彭希仁在2008-5-28 17:24:04的发言:




 

LZ喜欢算法!

这是以前做过的一个树形存储(见附件)。其中一个算法至今不满意,讨教LZ看有否高招!

为了不造成一个框框,我的代码先不贴出!

 

5crDrmyX.rar (5.08 KB, 下载次数: 85)

TA的精华主题

TA的得分主题

发表于 2008-5-29 18:49 | 显示全部楼层
QUOTE:
以下是引用丸究阵引在2008-5-29 18:16:00的发言:

 

LZ喜欢算法!

这是以前做过的一个树形存储(见附件)。其中一个算法至今不满意,讨教LZ看有否高招!

为了不造成一个框框,我的代码先不贴出!


感觉做法和做家谱是一样的,每个人必需要有唯一的ID号,

同时他的父亲ID,哥的ID,弟的ID.长子的ID.必需要一行中标出来,这有这样才有可能为后面的删除和添加提供方便,当然按照你这种方法也行,但那样只能是一次成形,后面要修改就麻烦了

TA的精华主题

TA的得分主题

发表于 2008-5-29 20:06 | 显示全部楼层
QUOTE:
以下是引用43379677在2008-5-29 18:49:27的发言:

感觉做法和做家谱是一样的,每个人必需要有唯一的ID号,

同时他的父亲ID,哥的ID,弟的ID.长子的ID.必需要一行中标出来,这有这样才有可能为后面的删除和添加提供方便,当然按照你这种方法也行,但那样只能是一次成形,后面要修改就麻烦了

这是一个无级的树形,同一级可重复,想过用唯一ID可麻烦不少,未尝试。数据存储在MDB添加删除不是很复杂。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

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

GMT+8, 2019-9-22 03:18 , Processed in 0.074975 second(s), 13 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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