Excel Workbook & Tabs List

[bradh_nz]

Hi
Does anyone know of any code out there that you could run over a selected folder structure that would give you a list of all the excel spreadsheets within that folder and a list of all teh tabs (worksheets within).

Thanks
Brad

[Bob Phillips]

This gives you a hyperlinked list of files, you will need to extend for sheets

[vba]

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

[rory]

This is a list of files and sheets (not hyperlinked though):
[vba]Sub ListFilesAndSheets()
Dim FS As FileSearch
Dim lngCounter As Long, lngRow As Long, lngOutputrow As Long, lngSheetCount As Long
Dim wbk As Workbook, wks As Worksheet
Dim rngData As Range
Dim strParentFolder As String
Dim varSheets
strParentFolder = GetFolder()
If Len(strParentFolder) = 0 Then Exit Sub
Application.ScreenUpdating = False
lngOutputrow = 1
Set FS = Application.FileSearch
With FS
.NewSearch
.LookIn = strParentFolder
.SearchSubFolders = True
.Filename = "*.xls"
.MatchTextExactly = True
.FileType = msoFileTypeExcelWorkbooks
.Execute
' Loop through all the found files
For lngCounter = 1 To .FoundFiles.Count
varSheets = ListSheetsInFile(.FoundFiles(lngCounter))
lngSheetCount = UBound(varSheets)
Cells(lngOutputrow, 1).Value = .FoundFiles(lngCounter)
Range(Cells(lngOutputrow, 2), Cells(lngOutputrow + lngSheetCount - 1, 2)).Value = Application.Transpose(varSheets)
lngOutputrow = lngOutputrow + lngSheetCount
Next lngCounter
End With
Set FS = Nothing
Application.ScreenUpdating = True
End Sub
Function ListSheetsInFile(ByVal strFile As String) As String()
Dim xlConn As Object 'ADODB.Connection
Dim xlSheets As Object 'ADODB.Recordset
Dim astrSheets() As String, strSheet As String
Dim lngSheetCounter As Long
' On Error GoTo err_handler
'connect to the file
Set xlConn = CreateObject("ADODB.Connection")
With xlConn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties") = "Excel 8.0;IMEX=1"
.Open strFile
End With
lngSheetCounter = 1
'see sheet names in the immediate window
Set xlSheets = xlConn.OpenSchema(20) '20=adSchemaTables
With xlSheets
Do While Not .EOF
strSheet = .Fields("TABLE_NAME").Value
If InStr(1, strSheet, "$") > 0 Then
If Right$(Replace$(strSheet, "'", ""), 1) = "$" Then
ReDim Preserve astrSheets(1 To lngSheetCounter)
astrSheets(lngSheetCounter) = Replace$(Left$(strSheet, InStr(1, strSheet, "$") - 1), "'", "")
lngSheetCounter = lngSheetCounter + 1
End If
End If
.MoveNext
Loop
End With
clean_up:
On Error Resume Next
ListSheetsInFile = astrSheets()
xlSheets.Close
Set xlSheets = Nothing
xlConn.Close
Set xlConn = Nothing
Exit Function

err_handler:
MsgBox Err.Number & ": " & Err.Description
Resume clean_up
End Function
Function GetFolder() As String
Dim dlg As FileDialog
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
If dlg.Show = -1 Then
GetFolder = dlg.SelectedItems(1)
End If
End Function
[/vba]