勉強ブログ

Option Explicit

' 指定したフォルダ内のファイルの一覧を取得
Sub Display_Directory()
Const cnsTitle = "フォルダ内のファイル名一覧取得"
Const cnsDIR = "\*.*"
Dim xlAPP As Application
Dim THIS_WORKBOOK_NAME As String

Dim strPathName As String, vntPathName As Variant
Dim vntSheet As Variant
Dim strFileName As String
Dim line As Long

THIS_WORKBOOK_NAME = ThisWorkbook.Name
'開始行番号
line = 2

Set xlAPP = Application
' InputBoxでフォルダ指定を受ける
vntPathName = xlAPP.InputBox("参照するフォルダ名を入力して下さい。", _
cnsTitle, CurDir)
If VarType(vntPathName) = vbBoolean Then Exit Sub
strPathName = vntPathName
' フォルダの存在確認
If Dir(strPathName, vbDirectory) = "" Then
MsgBox "指定のフォルダは存在しません。", vbExclamation, cnsTitle
Exit Sub
End If

' 先頭のファイル名の取得
strFileName = Dir(strPathName & cnsDIR, vbNormal)
' ファイルが見つからなくなるまで繰り返す
Do While strFileName <> ""

' Excelのみ対象
If (InStr(1, strFileName, ".xls", vbTextCompare)) <> 0 And strFileName <> THIS_WORKBOOK_NAME Then


Workbooks.Open Filename:= _
vntPathName & "\" & strFileName

For Each vntSheet In Sheets
'ファイル名を1列目にセット
Workbooks(1).Sheets(1).Cells(line, 1).Value = strFileName
Workbooks(1).Sheets(1).Cells(line, 2).Value = vntSheet.Name
' 行を加算
line = line + 1
Next vntSheet

ActiveWindow.Close

End If

' 次のファイル名を取得
strFileName = Dir()
Loop

Call MsgBox("ファイル・シート名出力が完了しました", vbOKOnly, "終了メッセージ")
End Sub