FSO サブフォルダ含めすべて取得

※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。

※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。

Sub GetFolderAndFile()
'*****************************************************************
'指定したディレクトリ内のすべてのサブフォルダ及びファイルを取得
'*****************************************************************
'*２層以下は取得しません
'*Visual Basic 6.0 及び VBA
'*Microsoft Scripting Runtime(FSO)要参照設定
'EXCEL.BOOK新しいシートを追加しそこに列挙

Dim sht As Worksheet
Dim lIndex As Long
Dim hFolder As Folder
Dim subFolder As Folder
Dim Fso As FileSystemObject
Dim hFile As File
Dim iFolder As Folder

Set Fso = New FileSystemObject
Set hFolder = Fso.GetFolder(ThisWorkbook.Path & "\")
Set sht = ThisWorkbook.Worksheets.Add

With sht
'1.直下のファイル名取得(この場合このコードが実装されているファイル名が入る）
    lIndex = 1
        For Each hFile In hFolder.Files
            .Cells(lIndex, 1).Value = hFile.Name 'ファイル名のみの場合
            lIndex = lIndex + 1
        Next hFile

'2.直下のフォルダ名及びファイル名取得
        For Each subFolder In hFolder.SubFolders
            .Cells(lIndex, 2).Value = "[" & subFolder.Name & "]"
            lIndex = lIndex + 1
            Set iFolder = Fso.GetFolder(subFolder.Path & "\")
                For Each hFile In iFolder.Files
                    .Cells(lIndex, 3).Value = hFile.Name
                    lIndex = lIndex + 1
                Next hFile
            Set iFolder = Nothing
        Next subFolder
End With

Set Fso = Nothing
Set subFolder = Nothing
Set hFolder = Nothing
Set hFile = Nothing
Set sht = Nothing

End Sub

 

2000年01月01日|[VBサンプルコード]:[FSO]