Find Excel workbooks in many SubFolders and create hyperlink for it

[tommy1234]

i have a folder with a lot of sub folders. i want to create an excel worksheet that will be a "tree view" of all the folders and sub folders.
under every folder / subfolder there will be all the excel workbooks (as hyperlinks) that this folder contains.
my knowledge in vba is poor.
need your help.
thanks

for exmple :
c:\project
c:\project\a.xls
c:\project\first\
c:\project\first\b.xls
(everything display as hyperlink)

[Bob Phillips]

[vba]

Option Explicit

Dim FSO As Object
Dim cnt As Long
Dim arfiles
Dim 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

Set FSO = CreateObject("Scripting.FileSystemObject")

arfiles = Array()
cnt = -1
level = 1

sFolder = "L:\Security"
ReDim arfiles(6, 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(6, i))
.Value = arfiles(5, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(6, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(5, i)
.Cells(i + 1, arfiles(6, i) + 1).Value = arfiles(1, i)
.Cells(i + 1, arfiles(6, i) + 2).Value = arfiles(2, i)
.Cells(i + 1, arfiles(6, i) + 3).Value = arfiles(3, i)
.Cells(i + 1, arfiles(6, i) + 4).Value = arfiles(4, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").Columns.AutoFit
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(6, cnt)
arfiles(0, cnt) = ""
arfiles(5, cnt) = arPath(level - 1)
arfiles(6, cnt) = level

Set oFolder = FSO.GetFolder(sPath)
Set oFiles = oFolder.Files
For Each oFile In oFiles
cnt = cnt + 1
ReDim Preserve arfiles(6, cnt)
arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
arfiles(1, cnt) = Right(oFile.Name, Len(oFile.Name) -
InStrRev(oFile.Name, "."))
arfiles(2, cnt) = Format(oFile.DateCreated, "dd mmm yyyy")
arfiles(3, cnt) = Format(oFile.Size, "#,##0")
arfiles(4, cnt) = oFile.Path
arfiles(5, cnt) = oFile.Name
arfiles(6, 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(sText As String, _
Optional sDelim As String = " ") As Variant
'-----------------------------------------------------------------
Dim i%, sFml$, v0, v1
Const sDQ$ = """"

If sDelim = vbNullChar Then
sDelim = Chr(7)
sText = Replace(sText, vbNullChar, sDelim)
End If
sFml = "{""" & Application.Substitute(sText, sDelim, """,""") & """}"
v1 = Evaluate(sFml)
'Return 0 based for compatibility
ReDim v0(0 To UBound(v1) - 1)
For i = 0 To UBound(v0): v0(i) = v1(i + 1): Next

Split = v0

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
[/vba]

[Simon Lloyd]

Bob, i have code that does that and not as fancy, could you tell me where to put If Err.Number = 70 Then.....etc some folders of course are access denied and the code stops there however it would be nice if it didnt!

Regards,
Simon

[Bob Phillips]

I would guess that you do it in the SelectFiles procedure, add an error handler, and just trap it in there.

[tommy1234]

there is an error on line 91 and as i worte before my knowledge in vba is not so good need your help !!!
i added the line with the problem :
arfiles(1, cnt) = Right(oFile.Name, Len(oFile.Name) -
InStrRev(oFile.Name, "."))

thanks

[Bob Phillips]

Post the workbook and tell us which code line not line number please.