Solved: Searching all files and folders for Excel files?

[Simon Lloyd]

Does anyone know how to search through all files and folders in VBA?, i have some code below where i can specify a drive or folder, but if i only specify a drive like C:\ then it will only find the files saved on the C drive that aren't in folders, I would like to be able to loop through all files and folders in the drive i specify.....is it possible?

Regards,
Simon


Sub FindBooks()
Dim F As String, i As Integer, n As Integer, wks As Worksheet
i = 1
Set wks = ActiveWorkbook.Worksheets.Add wks.Cells(i, 1).Value = F
F = Dir("C:\Documents and Settings\Simon\my documents\*.xls", vbNormal)
Do While F <> ""
wks.Cells(i, 1).Value = F
i = i + 1
F = Dir
Loop
n = i - 1
MsgBox "there were " & n & " Files Found"
wks.Range(Cells(1, 1), Cells(n, 1)).Sort _
Key1:=wks.Cells(1, 1), Order1:=xlAscending, _
OrderCustom:=1, Orientation:=xlSortRows, _
Header:=xlNo, MatchCase:=False
Application.DisplayAlerts = False
F = "C:\Documents and Settings\Simon\my documents\Global Index.xls"
ActiveWorkbook.SaveAs Filename:=F
Application.DisplayAlerts = True
End Sub

[johnske]

Try FindFile. E.G.
Option Explicit

Sub TestTheFunction_Desktop()
CustomFindFile ("windows\desktop\*.xls")
End Sub

Sub TestTheFunction_EntireCdrive()
CustomFindFile ("*.xls")
End Sub

Function CustomFindFile(FileType As String)

' This procedure demonstrates a simple file-search
' routine that displays a list containing the
' names of all files in the 'lookIn' directory that
' match the file specifications provided in the
' FileType argument.
' The FileType argument can contain one or more file
' specifications in a semicolon-delimited list. For example, the
' following FileType argument will return all files
' in the "c:\" that contain these extensions: "*.log;*.bat;*.ini"

Dim MyFileSearch As Office.FileSearch
Dim varFile As Variant
Dim FileList As String

' If the input in valid, then process the file search.
If Len(FileType) >= 3 And InStr(FileType, "*.") > 0 Then
Set MyFileSearch = Application.FileSearch
With MyFileSearch
.NewSearch
.LookIn = "c:\"
.Filename = FileType
.SearchSubFolders = True

If .Execute() > 0 Then
For Each varFile In .FoundFiles
Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = varFile
Next
End If

End With
Else
MsgBox FileType & " is not a valid file specification."
Exit Function
End If

End Function

[Simon Lloyd]

Johnske, thanks for the very speedy reply!, if you look at my example i collect the names of the .slx files and save them in a workbook, when they are added to this workbook i convert the names to hyperlinks so that all workboks can be called from there, i understand what your version is doing (sort of!) but i dont understand how to limit the search to .xls extensions because this is all i'm interested in capturing, this way people at work will only have to access one workbook to find any of our workbooks. Could you help further?

Regards,
Simon

[Simon Lloyd]

Sorry didnt give you my example, this is the version where i can by way of an input box specify the drive and then turn all found into hyperlinks
Sub Main()
Dim F As String, i As Integer, n As Integer, wks As Worksheet
t1 = InputBox("Enter Location And Name Of Folder" & Chr(13) & "Or Drive Letter Followed By :\", "Excel Finder")
i = 1
On Error GoTo ErrHandler:
Worksheets("Index").Activate
ActiveSheet.Name = "Index"
ErrHandler:
If Err.Number = 9 Then
Worksheets.Add.Name = "Index"
Resume
End If

Set wks = Sheets("Index")
Sheets("Index").Select
Sheets("Index").Range("A:A").ClearContents
Sheets("Index").Range("A1").Select
wks.Cells(i, 1).Value = F


F = Dir(t1 & "*.xls", vbNormal)
Do While F <> "" 'loop through all the files
wks.Cells(i, 1).Value = F
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=t1 & F, TextToDisplay:=F
ActiveCell.Offset(1, 0).Select
i = i + 1
F = Dir
Loop
n = i - 1
MsgBox "File Finder Has Found " & n & " Files And Created Direct Links To each Of Them!", vbOKOnly, "File Finder Results"
Columns("A:A").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select
Application.DisplayAlerts = False
Application.DisplayAlerts = True
ActiveWorkbook.Save End Sub
Regards,
Simon

[Bob Phillips]

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:\" '<============== change to suit
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.FileSystemObject")
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

[Simon Lloyd]

Ive sorted it now Johnske by adding this lineActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=varFile, TextToDisplay:=varFile
ActiveCell.Offset(1, 0).SelectThanks for your help, it works a treat!

Regards,
Simon

[Simon Lloyd]

Wow! "El Xid" very comprehensive response i will give it a try, could you explain what LBound and Ubound do please?

Regards,
Simon

[mdmackillop]

Hi Simon,
When you create arrays using code, you may not know the values of all the elements, so you cannot hard code them. LBound(arr) is the first value and UBound(Arr) is the last value in the array Arr.

See the VBA help files for more detail.