Search worksheets in folder and sub folders

**gibbo1715** · 08-28-2005, 05:12 AM

Another question for you

I can search all workbooks within a directory, is there a way to also search all sub directories or is this not possible?

Cheers

Gibbo

**mdmackillop** · 08-28-2005, 05:19 AM

Hi Gibbo,
Have a look at this KB Item
http://vbaexpress.com/kb/getarticle.php?kb_id=245

**gibbo1715** · 08-28-2005, 05:37 AM

Thanks, that looks like a good place to start

Gibbo

**Norie** · 08-28-2005, 06:48 AM

Why not use the FileSearch object where you can specify to search sub folders?

**gibbo1715** · 08-28-2005, 06:51 AM

Norie, can you post an example for me

cheers

gibbo

**Norie** · 08-28-2005, 07:48 AM

Straight from VBA Help.

With Application.FileSearch 
     .NewSearch 
     .LookIn = "C:\My Documents" 
     .SearchSubFolders = True 
     .FileType = msoFileTypeAllFiles 
     If .Execute() > 0 Then
          MsgBox "There were " & .FoundFiles.Count &  " file(s) found." 
          For i = 1 To .FoundFiles.Count 
               MsgBox .FoundFiles(i)
          Next i
     Else 
          MsgBox "There were no files found." 
     End If
End With

**gibbo1715** · 08-28-2005, 08:23 AM

nice short method i hadnt seen before, thanks i ll have a play with it and see what i come up with

Gibbo

**gibbo1715** · 08-28-2005, 09:12 AM

Ok ended up with the code below which works fine until i try and save the workbook having run the search, excel then crashes, anyone got any idea why?

Sub FindTextString()
Dim i As Integer
Dim szSearchWord As Variant
szSearchWord = Application.InputBox("What are you looking for ?", "Search", , 100, 100, , , 2)
If szSearchWord = False Then
Sheets("Sheet1").Select
End
End If
With Application.FileSearch
.NewSearch
.LookIn = ThisWorkbook.Path
.FileType = msoFileTypeAllFiles
.SearchSubFolders = True
.TextOrProperty = szSearchWord
.Execute
MsgBox "There were " & .FoundFiles.Count & " file(s) found."
For i = 1 To .FoundFiles.Count
ActiveSheet.Range("b" & (i + 1)) = .FoundFiles(i) 'FoundFiles(i) 'Mid(.FoundFiles(i), _
'InStrRev(.FoundFiles(i), "\") + 1)
Next i
End With
Exit Sub
End Sub

Cheers

Gibbo

**Norie** · 08-28-2005, 09:46 AM

I can't see why that code would cause that problem.

**gibbo1715** · 08-28-2005, 09:48 AM

nor me, thats why im confused (Well more than normal anyway !!!)

Edit

I left it for a bit and came back to a message box - save not completed. File rename failed. retry?

Thats a new one on me,

Any Ideas

Gibbo

**gibbo1715** · 08-28-2005, 10:04 AM

I added the below to the end which solves my problem but i dont really want to save my workbook at this point, any ideas?

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Savename
Application.DisplayAlerts = True

**MWE** · 08-28-2005, 10:22 AM

Originally Posted by gibbo1715

Ok ended up with the code below which works fine until i try and save the workbook having run the search, excel then crashes, anyone got any idea why?

Sub FindTextString()
Dim i As Integer
Dim szSearchWord As Variant
szSearchWord = Application.InputBox("What are you looking for ?", "Search", , 100, 100, , , 2)
If szSearchWord = False Then
Sheets("Sheet1").Select
End
End If
With Application.FileSearch
.NewSearch
.LookIn = ThisWorkbook.Path
.FileType = msoFileTypeAllFiles
.SearchSubFolders = True
.TextOrProperty = szSearchWord
.Execute
MsgBox "There were " & .FoundFiles.Count & " file(s) found."
For i = 1 To .FoundFiles.Count
ActiveSheet.Range("b" & (i + 1)) = .FoundFiles(i) 'FoundFiles(i) 'Mid(.FoundFiles(i), _
'InStrRev(.FoundFiles(i), "\") + 1)
Next i
End With
Exit Sub
End Sub

Cheers

Gibbo

it may not be the code, but rather the combination of the code and the version of Excel and op/sys you are running. Some of these things are obvious due to new features or not-supported features. But some are not so obvious: I have code that runs flawlessly on computer A and is flakey on computer B. Both are running Excel2K but one has Win2K and the other WinXP. Also, I have noticed some differences in how Excel runs on WinXP/SP1 vs WinXP/SP2. For example, VBA help worked fine running Office2K under Win2K. VBA help never worked running the same Office2K under WinXP/SP1. But that same Office2K VBA Help works fine under WinXP/SP2.

Somewhere in the "how to get help" stickies there is something about clearly indicating computer, op/sys and MS appl version. We all forget at times.

**gibbo1715** · 08-28-2005, 10:33 AM

that sounds about right, im running office 2000 on win xp home edition.

Is there a way to do a save as without actually saving (If that makes any sense!!!!!)

i.e. trick excel into thinking the spreadsheet is saved where it should be again

**Justinlabenne** · 08-28-2005, 02:55 PM

How many files are being found?

Can you attach a sample in this thread? Cannot seem to duplicate the error here.

**Bob Phillips** · 08-29-2005, 05:38 AM

Here is a different way, using FSO instead of the flaky FileSearch. It also
searches down into sub-folders and indents the levels.

Option Explicit

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean
arfiles = Array()
    cnt = -1
    level = 1
sFolder = "E:\"
    ReDim arfiles(2, 0)
    If sFolder <> "" Then
        SelectFiles sFolder
        Application.DisplayAlerts = False
        On Error Resume Next
        Worksheets("Files").Delete
        On Error GoTo 0
        Application.DisplayAlerts = True
        Worksheets.Add.Name = "Files"
        With ActiveSheet
            For i = LBound(arfiles, 2) To UBound(arfiles, 2)
                If arfiles(0, i) = "" Then
                    If fOutline Then
                        Rows(iStart + 1 & ":" & iEnd).Rows.Group
                    End If
                    With .Cells(i + 1, arfiles(2, i))
                        .Value = arfiles(1, i)
                        .Font.Bold = True
                    End With
                    iStart = i + 1
                    iEnd = iStart
                    fOutline = False
                Else
                    .Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
                                    Address:=arfiles(0, i), _
                                    TextToDisplay:=arfiles(1, i)
                    iEnd = iEnd + 1
                    fOutline = True
                End If
            Next
            .Columns("A:Z").ColumnWidth = 5
        End With
    End If
    'just in case there is another set to group
    If fOutline Then
        Rows(iStart + 1 & ":" & iEnd).Rows.Group
    End If
Columns("A:Z").ColumnWidth = 5
    ActiveSheet.Outline.ShowLevels RowLevels:=1
    ActiveWindow.DisplayGridlines = False
End Sub


Sub SelectFiles(Optional sPath As String)
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath
If FSO Is Nothing Then
        Set FSO = CreateObject("SCripting.FileSy*stemObject")
    End If
If sPath = "" Then
        sPath = CurDir
    End If
arPath = Split(sPath, "\")
    cnt = cnt + 1
    ReDim Preserve arfiles(2, cnt)
    arfiles(0, cnt) = ""
    arfiles(1, cnt) = arPath(level - 1)
    arfiles(2, cnt) = level
Set oFolder = FSO.GetFolder(sPath)
    Set oFiles = oFolder.Files
    For Each oFile In oFiles
        cnt = cnt + 1
        ReDim Preserve arfiles(2, cnt)
        arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
        arfiles(1, cnt) = oFile.Name
        arfiles(2, cnt) = level + 1
    Next oFile
level = level + 1
    For Each oSubFolder In oFolder.Subfolders
        SelectFiles oSubFolder.Path
    Next
    level = level - 1
End Sub


#If VBA6 Then
#Else

Function Split(Text As String, _
        Optional Delimiter As String = ",") As Variant
Dim i As Long
Dim sFormula As String
Dim aryEval
Dim aryValues
If Delimiter = vbNullChar Then
        Delimiter = Chr(7)
        Text = Replace(Text, vbNullChar, Delimiter)
    End If
sFormula = "{""" & Application.Substitute(Text, Delimiter, """,""") & """}"
    aryEval = Evaluate(sFormula)
    ReDim aryValues(0 To UBound(aryEval) - 1)
    For i = 0 To UBound(aryValues)
            aryValues(i) = aryEval(i + 1)
    Next
Split = aryValues
End Function


Public Function InStrRev(stringcheck As String, _
                         ByVal stringmatch As String, _
                         Optional ByVal start As Long = -1)
Dim iStart As Long
Dim iLen As Long
Dim i As Long
If iStart = -1 Then
        iStart = Len(stringcheck)
    Else
        iStart = start
    End If
iLen = Len(stringmatch)
For i = iStart To 1 Step -1
        If Mid(stringcheck, i, iLen) = stringmatch Then
            InStrRev = i
            Exit Function
        End If
    Next i
    InStrRev = 0
End Function

#End If

**gibbo1715** · 08-29-2005, 05:43 AM

i ll have a try when i get near my own computer

Thanks for taking the trouble to reply

Gibbo

**Bob Phillips** · 08-29-2005, 05:44 AM

Originally Posted by gibbo1715

i ll have a try when i get near my own computer

Thanks for taking the trouble to reply

Gibbo

It doesn't do the search, it just links all the files in a worksheet, but you said you know how to do that, so I just gave an example of recursion using FSO.

**gibbo1715** · 08-29-2005, 05:48 AM

Thanks again

Gibbo

**gibbo1715** · 08-30-2005, 07:32 AM

i get an error at Set FSO = CreateObject("Scripting.FileSy*stemObject"), is this because i need to set up a refernece, and if so what to?

**gibbo1715** · 08-30-2005, 07:57 AM

figured out it needs a ref to msfile scripting object, and changed the line

Set FSO = CreateObject("SCripting.FileSy*stemObject")

to

Set FSO = CreateObject("Scripting.FileSystemObject")

then works fine

Cheers Gibbo

Thread: Search worksheets in folder and sub folders

Thread Tools

Display

Search worksheets in folder and sub folders

Posting Permissions