[RESOLVED] Directory Searching

I am using Excel 2003 & Access 2003

I need to search a directory structure looking for any Directories which
match a specific code. I am looking in all directories under a specified
directory, I might have as many as 15,000 directories in the tree.

Thus if I have a directory structure of

T:\Base Dir
---Tree One
------Dir 001
------Dir 002
------Dir 004
---Tree Two
------Dir 003
------Dir 005

Then searching for a pattern of 001 under T:\ would return
T:\Base Dir\Tree One\Dir 001

Whilst searching for it under T:\Base Dir\Tree Two would return an Empty
value.

I have tried Application.FileSearch, but it only returns Files, not directories.
I have also tried Dir, but this comes up with a memory error after about 50 calls.
I am currently trying SearchScope & ScopeFolder, but cannot find any documentation
on these, and currently cannot adjust the code from the help files to stop it
from searching my local computer, when I just want it to search a specified
directory.

Can anyone provide a fast searching method for directories only, or a tutorial on SearchScope and ScopeFolder.

Re: Directory Searching

here is a sub using DIR to return all directories that match a search pattern
i don't have as many folders as you, but had no memory errors when testing

i modified this from a file search routine

i returned the results in an array (arrfound) that must be declared globally as the sub is recursive

Code:

Sub findsubfolders(spath, spattern As String) Dim myfile As String, dirarr() As String, cnt As Long, i As Long ReDim dirarr(100) cnt = 0 myfile = Dir(spath & "\*.*", vbDirectory) Do While Not myfile = "" If Not myfile = "." And Not myfile = ".." Then If GetAttr(spath & "\" & myfile) = vbDirectory Then arrfound(UBound(arrfound) + 100) If LCase(myfile) Like LCase(spattern) Then If Not Len(arrfound(0)) = 0 Then ReDim Preserve arrfound(UBound(arrfound) + 1) arrfound(UBound(arrfound)) = spath & "\" & myfile End If If cnt = UBound(dirarr) Then ReDim Preserve dirarr(UBound(dirarr) + 100) dirarr(cnt) = spath & "\" & myfile cnt = cnt + 1 ' **** file search ' ElseIf LCase(myfile) Like LCase(spattern) Then dostuff spath & "\" & myfile End If End If myfile = Dir Loop If Not cnt = 0 Then cnt = cnt - 1 ReDim Preserve dirarr(cnt) For i = 0 To UBound(dirarr) findsubfolders dirarr(i), spattern Next End If End Sub

Code:

Sub findfile() 'set starting folder and files to match 'reset array ReDim arrfound(0) Call findsubfolders("C:\Documents and Settings\peter\My Documents", "my*") 'arrfound should contain all the folders (complete path) in the tree below the starting folder, that match the pattern End Sub

Re: Directory Searching

Thanks Westconn,

I had to make a few adjustments, but the code below works

However when I ran it against my current live directories, Circa 15,000+, it
took approx 10 Minutes to run.

Any ideas as to how it could be speeded up?

VB Code:

Global arrfound()
Sub findsubfolders(spath, spattern As String)
Dim myfile As String, dirarr() As String, cnt As Long, i As Long
 
ReDim dirarr(100)
cnt = 0
    myfile = Dir(spath & "\*.*", vbDirectory)
        Do While Not myfile = ""
            If Not myfile = "." And Not myfile = ".." Then
                If (GetAttr(spath & "\" & myfile) And vbDirectory) <> 0 Then
                    If LCase(myfile) Like LCase(spattern) Then
                        If Not IsEmpty(arrfound(UBound(arrfound))) Then
                            ReDim Preserve arrfound(UBound(arrfound) + 1)
                        End If
                        arrfound(UBound(arrfound)) = spath & "\" & myfile
                    End If
                    If cnt = UBound(dirarr) Then ReDim Preserve dirarr(UBound(dirarr) + 100)
                    dirarr(cnt) = spath & "\" & myfile
                    cnt = cnt + 1
'               **** file search
'               ElseIf LCase(myfile) Like LCase(spattern) Then dostuff spath & "\" & myfile
                End If
            End If
            myfile = Dir
        Loop
            If Not cnt = 0 Then
                cnt = cnt - 1
                ReDim Preserve dirarr(cnt)
                    For i = 0 To UBound(dirarr)
                        findsubfolders dirarr(i), spattern
                    Next
            End If
End Sub
 
Sub findfile()
'set starting folder and files to match
'reset array
Dim counter As Long
Dim StartTime As Date
    StartTime = Now
    OutputRow = 1
    CountRow = 1
ReDim arrfound(0)
    ThisWorkbook.Worksheets("Sheet1").Cells.Delete
    ThisWorkbook.Worksheets("Sheet2").Cells.Delete
Call findsubfolders("V:\Notes", "*10408*")
 
'arrfound will now contain all the folders (complete path) in the tree below the starting folder, that match the pattern
    If Not IsEmpty(arrfound) then
        For counter = LBound(arrfound) To UBound(arrfound)
            Debug.Print counter & " :: " & arrfound(counter)
        Next counter
    End if
    Debug.Print StartTime & " :: " & Now
End Sub

Re: Directory Searching

how long does it take to do a similar search in windows explorer?

the other method that would be simple to code is to use the file system object then you would not need to iterate through all the files, just work with the collections
i haven't tried to do this, but it would be worth testing, often the search would take as long, but in this case it may be quicker, you would need to add a reference to microsoft scripting runtime

Code:

Sub dirs(startpath, pattern) Dim fs As New FileSystemObject, sf As Object, dirarr() As String, cnt As Long ReDim dirarr(100) For Each sf In fs.GetFolder(startpath).SubFolders dirarr(cnt) = sf.Path cnt = cnt + 1 If LCase(sf.Name) Like LCase(pattern) Then If Not Len(foundarr(0)) = 0 Then ReDim Preserve foundarr(UBound(foundarr) + 1) foundarr(UBound(foundarr)) = sf.Path End If Next If Not cnt = 0 Then ReDim Preserve dirarr(cnt - 1) For i = 0 To UBound(dirarr) dirs dirarr(i), pattern Next End If End Sub Sub finddir() ReDim foundarr(0) dirs "C:\Documents and Settings\peter\My Documents", "my*" End Sub

try some speed test with this

Re: Directory Searching

Hi Westconn,

Windows Explorer took 7 Minutes.
The first code took approx 10 Minutes.
The new code took 16 minutes, had to make a few mods, posted below.
Looks like I will go with the first code you where kind enough to provide.

Many Thanks,

Torc:afrog:

VB Code:

Sub dirs(startpath, pattern)
Dim fs As New FileSystemObject, sf As Object, dirarr() As String, cnt As Long
Dim check As Long
    ReDim dirarr(100)
    cnt = 0
    For Each sf In fs.GetFolder(startpath).SubFolders
        dirarr(cnt) = sf.Path
        cnt = cnt + 1
        If LCase(sf.Name) Like LCase(pattern) Then
             If Not IsEmpty(arrfound(UBound(arrfound))) Then
                 ReDim Preserve arrfound(UBound(arrfound) + 1)
             End If
            arrfound(UBound(arrfound)) = sf.Path
        End If
        If cnt > UBound(dirarr) Then
            ReDim Preserve dirarr(UBound(dirarr) + 100)
        End If
    Next
    If Not cnt = 0 Then
    ReDim Preserve dirarr(cnt - 1)
        For i = 0 To UBound(dirarr)
            dirs dirarr(i), pattern
        Next
    End If
End Sub
Sub finddir()
Dim StartTime As Date
    StartTime = Now
    ReDim arrfound(0)
 
    dirs "V:\IssuanceDocumentation\Notes", "*10408*"
    
    For counter = LBound(arrfound) To UBound(arrfound)
        Debug.Print counter & " :: " & arrfound(counter)
    Next counter
    Debug.Print StartTime & " :: " & Now
End Sub

Re: [RESOLVED] Directory Searching

i did some testing myself, 6 loops with dir or fso 1 after the other in the order as listed

15.03125 fso
5.984375 dir
3.21875 dir
5.421875 fso

sort of strange results, looks like windows does some sort of caching

there is al so the option of using API jfindfirstfile and findnextfile, but i doubt if there will be any significant difference