■xlsブックのSheet一覧

ネタもないので...今日のレスから。
フォルダ選択して、フォルダ内のxlsブックのシート一覧を取得。

Option Explicit

Sub try()
　　Dim ws As Worksheet
　　Dim fd As String
　　Dim fn As String
　　Dim re As String
　　Dim i　As Long
　　Dim n　As Long
　　Dim v(0 To 65535, 1 To 2)

　　fd = FDselect
　　If Len(fd) = 0& Then Exit Sub
　　If MsgBox(fd & " の処理を行います。OK?", vbOKCancel) _
　　　　　　 = vbCancel Then Exit Sub
　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　　　.Calculation = xlCalculationManual
　　End With
　　v(0, 1) = "BookName"
　　v(0, 2) = "SheetName"
　　On Error GoTo errHndlr
　　fn = Dir(fd & "*.xls")
　　Do Until Len(fn) = 0&
　　　　If Not fn Like ThisWorkbook.Name Then
　　　　　　With Workbooks.Open(Filename:=fd & fn, _
　　　　　　　　　　　　　　　　Updatelinks:=False, _
　　　　　　　　　　　　　　　　ReadOnly:=True)
　　　　　　　　i = i + 1
　　　　　　　　For Each ws In .Worksheets
　　　　　　　　　　n = n + 1
　　　　　　　　　　v(n, 1) = fd & fn
　　　　　　　　　　'次行と入れ替えるとHYPERLINKつき
　　　　　　　　　　v(n, 2) = ws.Name
　　　　　　　　　　'v(n, 2) = "=HYPERLINK(""[" & fd & fn & "]'" _
　　　　　　　　　　　　　　　　　　　　　& ws.Name & "'!A1"",""" _
　　　　　　　　　　　　　　　　　　　　　& ws.Name & """)"
　　　　　　　　Next ws
　　　　　　　　.Close Savechanges:=False
　　　　　　End With
　　　　End If
　　　　fn = Dir()
　　Loop

errHndlr:
　　If i > 0& Then
　　　　Worksheets.Add.Range("A1").Resize(n + 1, 2).Formula = v
　　End If
　　With Application
　　　　.Calculation = xlCalculationAutomatic
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
　　If Err.Number = 0& Then
　　　　re = i & " Books & " & n & " Sheets" & vbLf & "処理終了"
　　Else
　　　　re = Err.Number & vbLf & Err.Description
　　End If
　　MsgBox re
　　Erase v
　　Set ws = Nothing
End Sub
'---------------------------------------------------------------------
Private Function FDselect() As String 'FolderSelectFunction
　　Dim obj As Object
　　Dim ret As String

　　Set obj = CreateObject("Shell.Application") _
　　　　　　　.BrowseForFolder(0, "SelectFolder", 0)
　　If obj Is Nothing Then Exit Function
　　On Error Resume Next
　　ret = obj.self.Path & "¥"
　　If Err.Number <> 0 Then
　　　　ret = obj.Items.Item.Path & "¥"
　　　　Err.Clear
　　End If
　　On Error GoTo 0
　　Set obj = Nothing
　　FDselect = ret
End Function

ぃや、特に変わった趣向は...ないです...:-(