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

彭希仁

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编辑过]

minjiwei

支持。看楼主的帖子很受启发

彭希仁

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

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

只观看

Dim d As New Dictionary这句说定义出错,可否改为本:Set d = CreateObject("Scripting.Dictionary") ?

彭希仁

QUOTE:

以下是引用只观看在2008-5-29 8:56:44的发言：
Dim d As New Dictionary这句说定义出错,可否改为本:Set d = CreateObject("Scripting.Dictionary") ?

当然可以

前期还要引用字典

realsoar

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

这个是我平时用的。

彭希仁

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

这个是我平时用的。

你这代码不错,学习了

丸究阵引

QUOTE:

以下是引用彭希仁在2008-5-28 17:24:04的发言：

 

LZ喜欢算法！

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

为了不造成一个框框，我的代码先不贴出！

 

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

2008-5-29 18:15 上传

点击文件名下载附件
递归 搜索文件(搜索目录及子目录)

43379677

QUOTE:

以下是引用丸究阵引在2008-5-29 18:16:00的发言：

 

LZ喜欢算法！

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

为了不造成一个框框，我的代码先不贴出！

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

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

丸究阵引

QUOTE:

以下是引用43379677在2008-5-29 18:49:27的发言：

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

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

这是一个无级的树形，同一级可重复,想过用唯一ID可麻烦不少，未尝试。数据存储在MDB添加删除不是很复杂。