PDA

View Full Version : Solved: 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
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.:devil:

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.

xld
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

xld
08-29-2005, 05:44 AM
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 haow 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

xld
08-30-2005, 08:16 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

Glad you got it to work, don't know where that * came from.

BUTyou don't need to set a reference, my code is late binding.