listing all sheets in all workbooks in a directory

[Todd Huttenstine]

Hey

I need to list all the worksheets in all the workbooks in a specfic
directory.

I need it to look in C:\Test and list the Workbook name and the sheet
name next to it. For example:
Workbook1 - Sheet1
Workbook1 - Sheet2
Workbook1 - Sheet3
Workbook1 - Sheet4
Workbook2 - Sheet1
Workbook2 - Sheet2
Workbook2 - Sheet3

What is the code fo rthis?
Thanks
Todd

 

[LenB]

This will do that.

Sub ShowSheets()

Dim strFileName As String
Dim wkbBook As Workbook
Dim I As Integer

'results will go in the active sheet of this workbook
ThisWorkbook.Activate
Range("A1").Activate
'loop thru all xls files in c:\test
strFileName = Dir("C:\test\*.xls")
Do While Len(strFileName) > 0
Set wkbBook = Workbooks.Open(FileName:="C:\test\" & _
strFileName, ReadOnly:=True)
For I = 1 To wkbBook.Worksheets.Count
ThisWorkbook.Activate
ActiveCell.Value = wkbBook.Name
Cells(ActiveCell.Row, 2).Value = wkbBook.Worksheets(I).Name
ActiveCell.Offset(1, 0).Activate
Next
wkbBook.Close
'gets the next file. When no more, returns empty string
strFileName = Dir()
Loop

End Sub

 

[Dave Peterson]

How about something like:

Option Explicit
Sub testme01()

Dim myNames() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim DestCell As Range
Dim wkbk As Workbook
Dim wks As Worksheet

'change to point at the folder to check
myPath = "c:\my documents\excel"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

myFile = ""
On Error Resume Next
myFile = Dir(myPath & "*.xls")
On Error GoTo 0
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

Application.ScreenUpdating = False

'get the list of files
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myNames(1 To fCtr)
myNames(fCtr) = myFile
myFile = Dir()
Loop

If fCtr > 0 Then
Set DestCell = Workbooks.Add(1).Worksheets(1).Range("a2")
DestCell.Parent.Range("a1").Resize(1, 2).Value _
= Array("WorkbookName", "WorksheetName")
DestCell.Parent.Range("a:b").NumberFormat = "@" 'make it text
For fCtr = LBound(myNames) To UBound(myNames)
Set wkbk = Workbooks.Open(Filename:=myPath & myNames(fCtr), _
UpdateLinks:=0, ReadOnly:=True)
For Each wks In wkbk.Worksheets
With DestCell
.Value = wkbk.Name
.Offset(0, 1).Value = wks.Name
End With
Set DestCell = DestCell.Offset(1, 0)
Next wks
wkbk.Close savechanges:=False
Next fCtr
End If

Application.ScreenUpdating = True

End Sub