★ 指定したフォルダ内の、すべてのサブフォルダを延々と掘っていって、『すべてのファイルとすべてのサブフォルダ』の基本情報を指定したシートにゲットする（吸い込む）プログラム。（再帰的な処理）

投稿日 : 2021-02-16 最終更新日時 : 2022-05-02 作成者 : vfaupe7 カテゴリー : 075012＿Excel2000VBATips

以降に挙げたプログラムを標準モジュールに単純にALLコピペして、
「GetFolderAndFileListMain02」のほうだけを実行します。
（※バージョン2000の場合はエラーになります）

なお、このプログラムを、他のプログラムに流用したい場合は、
「GetFolderAndFileListMain02」のほうの
「o_ImpWs01.Cells.ClearContents」から「End With '↑列名（項目名）を書き込む」というところまでをカットし、
「GetFolderAndFileListSub」のほうの
２つのFor Each のループの中を、書き換えます。

ただその場合、「GetFolderAndFileListSub」のほうは、
基本、
１つ目のFor Each のループ（サブフォルダのみに対する処理）は、

For Each myFolder In FSO.GetFolder(s_folderPath).subfolders
　Call GetFolderAndFileListSub(o_ImpSheet, myFolder.Path, myCount)
Next myFolder

の３行だけがあればOKです。
下記のプログラムでは、事例として「サブフォルダの内容もゲットしたい」ということでやりましたので色々書いてありますが、
通常は、「ファイルたち」「だけ」に何かしたい場合が多いので、
その場合は、
２つ目のFor Each のループの内容だけ書き換えて（あるいは関数化して）、
１つ目のFor Each のループは、上記の３行だけがあればOKです。

'
'
Option Explicit
 
'####################################################
'すべてのファイルとフォルダの情報を調べたい、
'その「フォルダ」と、
'その情報を吸い込みたいシートを指定する処理。
'####################################################
 
Sub GetFolderAndFileListMain02()

 
    Dim o_AnswFDialg    As FileDialog
    Dim s_PickFldPath   As String
    Dim o_ImpWs01       As Worksheet
    

    '★ 設定部

'    s_FoldPath = "D:\1"    
     '↑ バージョン2000の場合は、「FileDialog」が無くてエラーに
     '　なるので、こちらのコードを使って、以降の「FileDialog」がらみの
     '　コードは全部コメントアウトする。
  
    Set o_AnswFDialg = Application. _
                        FileDialog(msoFileDialogFolderPicker)
    '↑ファイル選択ダイアログを使えるように準備。
    

'    Set o_ImpWs01 = Application. _
                      Workbooks.Item("ブック名"). _
'                      Worksheets.Item("シート名")
    Set o_ImpWs01 = ActiveWorkbook. _
                             ActiveSheet
    '↑ファイル情報を吸い込むシートを指定。
    
    
    
    '★ 実動部

    If Not o_AnswFDialg.Show Then
        Exit Sub
        '↑キャンセルされたときは終わる。
    Else
        s_PickFldPath = o_AnswFDialg.SelectedItems(1)
        '↑フォルダが選択されたら、
        '　ファイル選択ダイアログのオブジェクトの「SelectedItems プロパティ」にフォルダパスが自動的にゲットされるので、
        '　一時的な処理として、いったん適当な変数にそれをメモ代入。
    End If
    '↑ファイル選択ダイアログを実際に開き、
    '　フォルダが選択されたら（＝フォルダパスがゲットできたら）
    '　そのパスを一時保管して次へ行き、
    '　キャンセルされたらプログラムを終わる。


    o_ImpWs01.Cells.ClearContents
    '↑いったん、指定したシートをオールクリアして真っ白にする。
    
    
    With o_ImpWs01
        .Range("A1") = "パス"
        .Range("B1") = "容量（KB）"
        .Range("C1") = "種類"
        .Range("D1") = "作成日時"
        .Range("E1") = "アクセス日時"
        .Range("F1") = "更新日時"
    End With
    '↑列名（項目名）を書き込む
    
        

'    Call getFolderAndFileListSub(folderPath:=s_FoldPath)

    Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _
                                 s_folderPath:=s_PickFldPath)

    '↑リスト作成の実行。
    '　ピックアップされたフォルダバスの中を、
    '　すべてのサブフォルダのすべてのファイルを対象に、
    '　o_ImpWs01 に指定したシートにファイル情報を吸い込む（＝書き込む）。
    
    
    
End Sub



'####################################################
'実際にすべてのサブフォルダたちとファイルたちの、
'ファイルとフォルダの基本情報を、
'指定したシートに吸い込む処理。
'####################################################


 
Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _
                            s_folderPath As String, _
                            Optional myCount As Long = 1)
 
 
   
'    Dim fso As New FileSystemObject        '←参照設定しないように作り変えたのでコメントアウト
    Dim FSO As Object
'    Dim o_FolderItem As Folder                 '←参照設定しないようにしたのでコメントアウトして次行のように書き換え
    Dim o_FolderItem As Object
'    Dim o_FileItem As File                     '←参照設定しないようにしたのでコメントアウトして次行のように書き換え
    Dim o_FileItem As Object
'    Dim Ws01 As Worksheet                  '←情報を吸い込むシートも引数化したのでコメントアウト


    '★ 設定部
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    '↑参照設定しなくてもFSO（FileSystemObject）を使えるようにする。

'    Set Ws01 = ActiveWorkbook.ActiveSheet '←情報を吸い込むシートも引数にしたのでコメントアウト
    
    On Error Resume Next
        
        
        
    '★ 実働部
        
    'サブフォルダを再帰的に覗いていって処理。
    For Each o_FolderItem In FSO.GetFolder(s_folderPath).subfolders

        myCount = myCount + 1
        'ファイル情報を吸い込みたいシートの、
        'どの行に書き込みたいかを設定する


'        With Ws01
        With o_ImpSheet
            .Cells(myCount, 1) = o_FolderItem.Path & "\  (DIR)"         'サブフォルダのフルパスの書込み。「(DIR)」という目印あり。
'            .Cells(myCount, 1) = o_FolderItem.Path                      '同上。目印なし。
'            .Cells(myCount, 2) = Int(o_FolderItem.Size / 1024)          'サブフォルダのKBでの容量（整数。右クリックプロパティの「サイズ」の値に合わせない。）
            .Cells(myCount, 2) = Round(o_FolderItem.Size / 1024, 1)     'サブフォルダのKBでの容量（小数。右クリックプロパティの「サイズ」の値に合わせる。「詳細表示」のリスト表示の「サイズ」の値とは異なります。）
            .Cells(myCount, 3) = o_FolderItem.Type                      'オブジェクトの種類（フォルダ、××ファイル、など）
            .Cells(myCount, 4) = o_FolderItem.DateCreated               'サブフォルダの作成日
            .Cells(myCount, 5) = o_FolderItem.DateLastAccessed          'サブフォルダの最終アクセス日時
            .Cells(myCount, 6) = o_FolderItem.DateLastModified          'サブフォルダの最終更新日
        End With
        '↑ファイル情報を吸い込みたいシートに、具体内容を吸い込む。


        Call GetFolderAndFileListSub(o_ImpSheet, o_FolderItem.Path, myCount)
        '↑サブフォルダのサブフォルダを、（再帰的に）終わるまでどんどん掘っていく。
        '　サブフォルダが見つかるたびに、更に掘っていく。

    Next o_FolderItem
    '↑「サブフォルダのみを延々と深く最後まで掘っていくループ
    '　（この段階ではサブフォルダのフォルダ情報のみをゲット。
    '　　サブフォルダ内のファイルたちの情報は次の段階のForEachループでゲット。）
'

       

    '現在のフォルダの中「だけ」の、ファイル一覧の書き出し。（サブフォルダも含む）
    'コメント内容は前述の「サブフォルダ延々掘り」のときとおおむね同じ。（フォルダ情報がファイル情報になっただけ）
    For Each o_FileItem In FSO.GetFolder(s_folderPath).Files
    
        myCount = myCount + 1
        
'        With Ws01
        With o_ImpSheet
            .Cells(myCount, 1) = o_FileItem.Path                    'ファイルのフルパスを書き込む
'            .Cells(myCount, 2) = Int(o_FileItem.Size / 1024)        'ファイルの容量（整数。KB単位。プロパティの「サイズ」の値に合わせない。）
            .Cells(myCount, 2) = Round(o_FileItem.Size / 1024, 1)   'ファイルの容量（小数。KB単位。プロパティの「サイズ」の値に合わせる。「詳細表示」のリスト表示の「サイズ」の値とは異なります。）
            .Cells(myCount, 3) = o_FileItem.Type                    'ファイルの種類
            .Cells(myCount, 4) = o_FileItem.DateCreated             'ファイルの作成日
            .Cells(myCount, 5) = o_FileItem.DateLastAccessed        'ファイルの最終アクセス日
            .Cells(myCount, 6) = o_FileItem.DateLastModified        'ファイルの最終更新日
        End With
        
    Next o_FileItem
        

 
End Sub
'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

Option Explicit

'####################################################

'すべてのファイルとフォルダの情報を調べたい、

'その「フォルダ」と、

'その情報を吸い込みたいシートを指定する処理。

'####################################################

Sub GetFolderAndFileListMain02()

Dim o_AnswFDialg As FileDialog

Dim s_PickFldPath As String

Dim o_ImpWs01 As Worksheet

'★ 設定部

' s_FoldPath = "D:\1"

'↑ バージョン2000の場合は、「FileDialog」が無くてエラーに

'　なるので、こちらのコードを使って、以降の「FileDialog」がらみの

'　コードは全部コメントアウトする。

Set o_AnswFDialg = Application. _

FileDialog(msoFileDialogFolderPicker)

'↑ファイル選択ダイアログを使えるように準備。

' Set o_ImpWs01 = Application. _

Workbooks.Item("ブック名"). _

' Worksheets.Item("シート名")

Set o_ImpWs01 = ActiveWorkbook. _

ActiveSheet

'↑ファイル情報を吸い込むシートを指定。

'★ 実動部

If Not o_AnswFDialg.Show Then

Exit Sub

'↑キャンセルされたときは終わる。

Else

s_PickFldPath = o_AnswFDialg.SelectedItems(1)

'↑フォルダが選択されたら、

'　ファイル選択ダイアログのオブジェクトの「SelectedItems プロパティ」にフォルダパスが自動的にゲットされるので、

'　一時的な処理として、いったん適当な変数にそれをメモ代入。

End If

'↑ファイル選択ダイアログを実際に開き、

'　フォルダが選択されたら（＝フォルダパスがゲットできたら）

'　そのパスを一時保管して次へ行き、

'　キャンセルされたらプログラムを終わる。

o_ImpWs01.Cells.ClearContents

'↑いったん、指定したシートをオールクリアして真っ白にする。

With o_ImpWs01

.Range("A1") = "パス"

.Range("B1") = "容量（KB）"

.Range("C1") = "種類"

.Range("D1") = "作成日時"

.Range("E1") = "アクセス日時"

.Range("F1") = "更新日時"

End With

'↑列名（項目名）を書き込む

' Call getFolderAndFileListSub(folderPath:=s_FoldPath)

Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _

s_folderPath:=s_PickFldPath)

'↑リスト作成の実行。

'　ピックアップされたフォルダバスの中を、

'　すべてのサブフォルダのすべてのファイルを対象に、

'　o_ImpWs01 に指定したシートにファイル情報を吸い込む（＝書き込む）。

End Sub

'####################################################

'実際にすべてのサブフォルダたちとファイルたちの、

'ファイルとフォルダの基本情報を、

'指定したシートに吸い込む処理。

'####################################################

Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _

s_folderPath As String, _

Optional myCount As Long = 1)

' Dim fso As New FileSystemObject '←参照設定しないように作り変えたのでコメントアウト

Dim FSO As Object

' Dim o_FolderItem As Folder '←参照設定しないようにしたのでコメントアウトして次行のように書き換え

Dim o_FolderItem As Object

' Dim o_FileItem As File '←参照設定しないようにしたのでコメントアウトして次行のように書き換え

Dim o_FileItem As Object

' Dim Ws01 As Worksheet '←情報を吸い込むシートも引数化したのでコメントアウト

'★ 設定部

Set FSO = CreateObject("Scripting.FileSystemObject")

'↑参照設定しなくてもFSO（FileSystemObject）を使えるようにする。

' Set Ws01 = ActiveWorkbook.ActiveSheet '←情報を吸い込むシートも引数にしたのでコメントアウト

On Error Resume Next

'★ 実働部

'サブフォルダを再帰的に覗いていって処理。

For Each o_FolderItem In FSO.GetFolder(s_folderPath).subfolders

myCount = myCount + 1

'ファイル情報を吸い込みたいシートの、

'どの行に書き込みたいかを設定する

' With Ws01

With o_ImpSheet

.Cells(myCount, 1) = o_FolderItem.Path & "\ (DIR)" 'サブフォルダのフルパスの書込み。「(DIR)」という目印あり。

' .Cells(myCount, 1) = o_FolderItem.Path '同上。目印なし。

' .Cells(myCount, 2) = Int(o_FolderItem.Size / 1024) 'サブフォルダのKBでの容量（整数。右クリックプロパティの「サイズ」の値に合わせない。）

.Cells(myCount, 2) = Round(o_FolderItem.Size / 1024, 1) 'サブフォルダのKBでの容量（小数。右クリックプロパティの「サイズ」の値に合わせる。「詳細表示」のリスト表示の「サイズ」の値とは異なります。）

.Cells(myCount, 3) = o_FolderItem.Type 'オブジェクトの種類（フォルダ、××ファイル、など）

.Cells(myCount, 4) = o_FolderItem.DateCreated 'サブフォルダの作成日

.Cells(myCount, 5) = o_FolderItem.DateLastAccessed 'サブフォルダの最終アクセス日時

.Cells(myCount, 6) = o_FolderItem.DateLastModified 'サブフォルダの最終更新日

End With

'↑ファイル情報を吸い込みたいシートに、具体内容を吸い込む。

Call GetFolderAndFileListSub(o_ImpSheet, o_FolderItem.Path, myCount)

'↑サブフォルダのサブフォルダを、（再帰的に）終わるまでどんどん掘っていく。

'　サブフォルダが見つかるたびに、更に掘っていく。

Next o_FolderItem

'↑「サブフォルダのみを延々と深く最後まで掘っていくループ

'　（この段階ではサブフォルダのフォルダ情報のみをゲット。

'　　サブフォルダ内のファイルたちの情報は次の段階のForEachループでゲット。）

'現在のフォルダの中「だけ」の、ファイル一覧の書き出し。（サブフォルダも含む）

'コメント内容は前述の「サブフォルダ延々掘り」のときとおおむね同じ。（フォルダ情報がファイル情報になっただけ）

For Each o_FileItem In FSO.GetFolder(s_folderPath).Files

myCount = myCount + 1

' With Ws01

With o_ImpSheet

.Cells(myCount, 1) = o_FileItem.Path 'ファイルのフルパスを書き込む

' .Cells(myCount, 2) = Int(o_FileItem.Size / 1024) 'ファイルの容量（整数。KB単位。プロパティの「サイズ」の値に合わせない。）

.Cells(myCount, 2) = Round(o_FileItem.Size / 1024, 1) 'ファイルの容量（小数。KB単位。プロパティの「サイズ」の値に合わせる。「詳細表示」のリスト表示の「サイズ」の値とは異なります。）

.Cells(myCount, 3) = o_FileItem.Type 'ファイルの種類

.Cells(myCount, 4) = o_FileItem.DateCreated 'ファイルの作成日

.Cells(myCount, 5) = o_FileItem.DateLastAccessed 'ファイルの最終アクセス日

.Cells(myCount, 6) = o_FileItem.DateLastModified 'ファイルの最終更新日

End With

Next o_FileItem

End Sub

★ 【ひな型化】～サブフォルダーを掘っていくループにさせたいことと、現在のフォルダのループにさせたいことを、さらに、関数化・分離した場合のテスト（引数の、他のプロシージャへの参照渡しでのさらなる引継ぎも含め）

以下のように、分割すれば、「サブフォルダを延々と掘って処理していくプログラム」がある程度「ひな型化」できるかも？
（※↓一応動きますがチェックが甘いのでちゃんと使えるかわかりません。あくまでもテストです。↓）

'
'
Option Explicit
 
'####################################################
'すべてのファイルとフォルダの情報を調べたい、
'その「フォルダ」と、
'その情報を吸い込みたいシートを指定する処理。
'####################################################
 
Sub GetFolderAndFileListMain02()
 
 
    Dim o_AnswFDialg    As FileDialog
    Dim s_PickFldPath   As String
    Dim o_ImpWs01       As Worksheet
    
 
    '★ 設定部
 
'    s_FoldPath = "D:\1"
     '↑ バージョン2000の場合は、「FileDialog」が無くてエラーに
     '　なるので、こちらのコードを使って、以降の「FileDialog」がらみの
     '　コードは全部コメントアウトする。

    Set o_AnswFDialg = Application. _
                        FileDialog(msoFileDialogFolderPicker)
    '↑ファイル選択ダイアログを使えるように準備。
    
 
'    Set o_ImpWs01 = Application. _
                      Workbooks.Item("ブック名"). _
'                      Worksheets.Item("シート名")

    Set o_ImpWs01 = ActiveWorkbook. _
                             ActiveSheet
    '↑ファイル情報を吸い込むシートを指定。
    
    
    
    '★ 実動部
 
    If Not o_AnswFDialg.Show Then
        Exit Sub
        '↑キャンセルされたときは終わる。
    Else
        s_PickFldPath = o_AnswFDialg.SelectedItems(1)
        '↑フォルダが選択されたら、
        '　ファイル選択ダイアログのオブジェクトの「SelectedItems プロパティ」にフォルダパスが自動的にゲットされるので、
        '　一時的な処理として、いったん適当な変数にそれをメモ代入。
    End If
    '↑ファイル選択ダイアログを実際に開き、
    '　フォルダが選択されたら（＝フォルダパスがゲットできたら）
    '　そのパスを一時保管して次へ行き、
    '　キャンセルされたらプログラムを終わる。
 

     '◆◆◆↓アクティブシートに何もしないなら以下のブロックは消して良い。
    o_ImpWs01.Cells.ClearContents
    '↑いったん、指定したシートをオールクリアして真っ白にする。
    
    '◆◆◆↓アクティブシートに何もしないなら以下のブロックは消して良い。
    With o_ImpWs01
        .Range("A1") = "パス"
        .Range("B1") = "容量（KB）"
        .Range("C1") = "種類"
        .Range("D1") = "作成日時"
        .Range("E1") = "アクセス日時"
        .Range("F1") = "更新日時"
    End With
    '↑列名（項目名）を書き込む
    
        
 
'    Call getFolderAndFileListSub(folderPath:=s_FoldPath)
 
    Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _
                                 s_folderPath:=s_PickFldPath)
 
    '↑リスト作成の実行。
    '　ピックアップされたフォルダバスの中を、
    '　すべてのサブフォルダのすべてのファイルを対象に、
    '　o_ImpWs01 に指定したシートにファイル情報を吸い込む（＝書き込む）。
    
    
    
End Sub
 
 
 
'####################################################
'実際にすべてのサブフォルダたちとファイルたちの、
'ファイルとフォルダの基本情報を、
'指定したシートに吸い込む処理。
'####################################################
 
 
 
Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _
                            s_folderPath As String, _
                            Optional myCount As Long = 1)
 
 
   
'    Dim fso As New FileSystemObject        '←参照設定しないように作り変えたのでコメントアウト
    Dim FSO As Object
'    Dim o_FolderItem As Folder                 '←参照設定しないようにしたのでコメントアウトして次行のように書き換え
    Dim o_FolderItem As Object
'    Dim o_FileItem As File                     '←参照設定しないようにしたのでコメントアウトして次行のように書き換え
    Dim o_FileItem As Object
'    Dim Ws01 As Worksheet                  '←情報を吸い込むシートも引数化したのでコメントアウト
 
 
    '★ 設定部
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    '↑参照設定しなくてもFSO（FileSystemObject）を使えるようにする。
 
'    Set Ws01 = ActiveWorkbook.ActiveSheet '←情報を吸い込むシートも引数にしたのでコメントアウト
    
    On Error Resume Next
        
        
        
    '★ 実働部
        
    'サブフォルダを再帰的に覗いていって処理。
    For Each o_FolderItem In FSO.GetFolder(s_folderPath).subfolders
 
        myCount = myCount + 1
        'ファイル情報を吸い込みたいシートの、
        'どの行に書き込みたいかを設定する

    '◆◆◆↓ サブフォルダに何もしないなら以下のブロックは
    '◆◆◆↓ 消しても良い。
        Call SubFolderWork01(o_ImpSheet, s_folderPath, myCount, o_FolderItem)
 
    Next o_FolderItem
    '↑「サブフォルダのみを延々と深く最後まで掘っていくループ
    '　（この段階ではサブフォルダのフォルダ情報のみをゲット。
    '　　サブフォルダ内のファイルたちの情報は次の段階のForEachループでゲット。）
'
 
       
 
    '現在のフォルダの中「だけ」の、すべてのファイルの
    '一覧の書き出し。（サブフォルダも含む）
    'コメント内容は前述の「サブフォルダ延々掘り」のときと
    'おおむね同じ。（フォルダ情報がファイル情報になっただけ）
    '　↓　 ↓
    For Each o_FileItem In FSO.GetFolder(s_folderPath).Files
    
        myCount = myCount + 1

    '◆◆◆↓ カレントフォルダの全ファイルに対して行う処理。
    '◆◆◆↓ カレントフォルダに何もしないなら以下のブロックは
    '◆◆◆↓ 消しても良い。
        Call CurrentFolderWork01(o_ImpSheet, s_folderPath, myCount, o_FileItem)
        
    Next o_FileItem
        
 
 
End Sub



'####################################################
'サブフォルダを掘るループにさせたい内容
'通常は、特にさせることはない。
'が、今回はサブフォルダの情報を知りたいので、以下のようなプログラムを書くことになる。
'引数は、TPO・目的によって、増やしたり減らしたり無くしたりする。
'また、参照渡しで、呼び出しモトの引数をそのまま引き継いでいます。
'◆◆◆ここのプロシージャはサブフォルダに対して何かするための
'◆◆◆プロシージャなので、サブフォルダに対して何もしないなら以下の
'◆◆◆コードは、FunctionやEnd Function 丸ごとを、
'◆◆◆すべてコメントアウトしても良い。
'####################################################

Function SubFolderWork01(o_ImpSheet As Worksheet, _
                         s_folderPath As String, _
                         myCount As Long, _
                         o_FolderItem As Object)

'◆◆◆ここのプロシージャはサブフォルダに対して何かするための
'◆◆◆プロシージャなので、サブフォルダに対して何もしないなら以下の
'◆◆◆コードは、FunctionやEnd Function 丸ごとを、
'◆◆◆すべてコメントアウトしても良い。

'オブジェクト変数「o_FolderItem」は、FSOを呼び出しモトでインスタンス化してしまっているので、
'この段階では固有型の「Folder」にはできず、総称型の「Object」にしかできない。

 
'        With Ws01
        With o_ImpSheet
            .Cells(myCount, 1) = o_FolderItem.Path & "\  (DIR)"         'サブフォルダのフルパスの書込み。「(DIR)」という目印あり。
'            .Cells(myCount, 1) = o_FolderItem.Path                      '同上。目印なし。
'            .Cells(myCount, 2) = Int(o_FolderItem.Size / 1024)          'サブフォルダのKBでの容量（整数。右クリックプロパティの「サイズ」の値に合わせない。）
            .Cells(myCount, 2) = Round(o_FolderItem.Size / 1024, 1)     'サブフォルダのKBでの容量（小数。右クリックプロパティの「サイズ」の値に合わせる。「詳細表示」のリスト表示の「サイズ」の値とは異なります。）
            .Cells(myCount, 3) = o_FolderItem.Type                      'オブジェクトの種類（フォルダ、××ファイル、など）
            .Cells(myCount, 4) = o_FolderItem.DateCreated               'サブフォルダの作成日
            .Cells(myCount, 5) = o_FolderItem.DateLastAccessed          'サブフォルダの最終アクセス日時
            .Cells(myCount, 6) = o_FolderItem.DateLastModified          'サブフォルダの最終更新日
        End With
        '↑ファイル情報を吸い込みたいシートに、具体内容を吸い込む。
 
 
        Call GetFolderAndFileListSub(o_ImpSheet, o_FolderItem.Path, myCount)
        '↑サブフォルダのサブフォルダを、（再帰的に）終わるまでどんどん掘っていく。
        '　サブフォルダが見つかるたびに、更に掘っていく。
        
End Function



'####################################################
'現在のフォルダの中でのループに、させたい内容
'通常は、こっちがメイン。
'    '◆◆◆ つまり、コメントアウトしちゃダメ！
'    '◆◆◆ ただし、アクティブシートに何もしない場合は
'    '◆◆◆ 該当するコードは消すか修正する。
'引数は、TPO・目的によって、増やしたり減らしたり無くしたりする。
'また、参照渡しで、呼び出しモトの引数をそのまま引き継いでいます。
'####################################################

Function CurrentFolderWork01(o_ImpSheet As Worksheet, _
                         s_folderPath As String, _
                         myCount As Long, _
                         o_FileItem As Object)



'オブジェクト変数「o_FileItem」は、FSOを呼び出しモトでインスタンス化してしまっているので、
'この段階では固有型の「File」にはできず、総称型の「Object」にしかできない。

 
'        With Ws01
        With o_ImpSheet
            .Cells(myCount, 1) = o_FileItem.Path                    'ファイルのフルパスを書き込む
'            .Cells(myCount, 2) = Int(o_FileItem.Size / 1024)        'ファイルの容量（整数。KB単位。プロパティの「サイズ」の値に合わせない。）
            .Cells(myCount, 2) = Round(o_FileItem.Size / 1024, 1)   'ファイルの容量（小数。KB単位。プロパティの「サイズ」の値に合わせる。「詳細表示」のリスト表示の「サイズ」の値とは異なります。）
            .Cells(myCount, 3) = o_FileItem.Type                    'ファイルの種類
            .Cells(myCount, 4) = o_FileItem.DateCreated             'ファイルの作成日
            .Cells(myCount, 5) = o_FileItem.DateLastAccessed        'ファイルの最終アクセス日
            .Cells(myCount, 6) = o_FileItem.DateLastModified        'ファイルの最終更新日
        End With
        
End Function

'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

Option Explicit

'####################################################

'すべてのファイルとフォルダの情報を調べたい、

'その「フォルダ」と、

'その情報を吸い込みたいシートを指定する処理。

'####################################################

Sub GetFolderAndFileListMain02()

Dim o_AnswFDialg As FileDialog

Dim s_PickFldPath As String

Dim o_ImpWs01 As Worksheet

'★ 設定部

' s_FoldPath = "D:\1"

'↑ バージョン2000の場合は、「FileDialog」が無くてエラーに

'　なるので、こちらのコードを使って、以降の「FileDialog」がらみの

'　コードは全部コメントアウトする。

Set o_AnswFDialg = Application. _

FileDialog(msoFileDialogFolderPicker)

'↑ファイル選択ダイアログを使えるように準備。

' Set o_ImpWs01 = Application. _

Workbooks.Item("ブック名"). _

' Worksheets.Item("シート名")

Set o_ImpWs01 = ActiveWorkbook. _

ActiveSheet

'↑ファイル情報を吸い込むシートを指定。

'★ 実動部

If Not o_AnswFDialg.Show Then

Exit Sub

'↑キャンセルされたときは終わる。

Else

s_PickFldPath = o_AnswFDialg.SelectedItems(1)

'↑フォルダが選択されたら、

'　ファイル選択ダイアログのオブジェクトの「SelectedItems プロパティ」にフォルダパスが自動的にゲットされるので、

'　一時的な処理として、いったん適当な変数にそれをメモ代入。

End If

'↑ファイル選択ダイアログを実際に開き、

'　フォルダが選択されたら（＝フォルダパスがゲットできたら）

'　そのパスを一時保管して次へ行き、

'　キャンセルされたらプログラムを終わる。

'◆◆◆↓アクティブシートに何もしないなら以下のブロックは消して良い。

o_ImpWs01.Cells.ClearContents

'↑いったん、指定したシートをオールクリアして真っ白にする。

'◆◆◆↓アクティブシートに何もしないなら以下のブロックは消して良い。

With o_ImpWs01

.Range("A1") = "パス"

.Range("B1") = "容量（KB）"

.Range("C1") = "種類"

.Range("D1") = "作成日時"

.Range("E1") = "アクセス日時"

.Range("F1") = "更新日時"

End With

'↑列名（項目名）を書き込む

' Call getFolderAndFileListSub(folderPath:=s_FoldPath)

Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _

s_folderPath:=s_PickFldPath)

'↑リスト作成の実行。

'　ピックアップされたフォルダバスの中を、

'　すべてのサブフォルダのすべてのファイルを対象に、

'　o_ImpWs01 に指定したシートにファイル情報を吸い込む（＝書き込む）。

End Sub

'####################################################

'実際にすべてのサブフォルダたちとファイルたちの、

'ファイルとフォルダの基本情報を、

'指定したシートに吸い込む処理。

'####################################################

Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _

s_folderPath As String, _

Optional myCount As Long = 1)

' Dim fso As New FileSystemObject '←参照設定しないように作り変えたのでコメントアウト

Dim FSO As Object

' Dim o_FolderItem As Folder '←参照設定しないようにしたのでコメントアウトして次行のように書き換え

Dim o_FolderItem As Object

' Dim o_FileItem As File '←参照設定しないようにしたのでコメントアウトして次行のように書き換え

Dim o_FileItem As Object

' Dim Ws01 As Worksheet '←情報を吸い込むシートも引数化したのでコメントアウト

'★ 設定部

Set FSO = CreateObject("Scripting.FileSystemObject")

'↑参照設定しなくてもFSO（FileSystemObject）を使えるようにする。

' Set Ws01 = ActiveWorkbook.ActiveSheet '←情報を吸い込むシートも引数にしたのでコメントアウト

On Error Resume Next

'★ 実働部

'サブフォルダを再帰的に覗いていって処理。

For Each o_FolderItem In FSO.GetFolder(s_folderPath).subfolders

myCount = myCount + 1

'ファイル情報を吸い込みたいシートの、

'どの行に書き込みたいかを設定する

'◆◆◆↓ サブフォルダに何もしないなら以下のブロックは

'◆◆◆↓ 消しても良い。

Call SubFolderWork01(o_ImpSheet, s_folderPath, myCount, o_FolderItem)

Next o_FolderItem

'↑「サブフォルダのみを延々と深く最後まで掘っていくループ

'　（この段階ではサブフォルダのフォルダ情報のみをゲット。

'　　サブフォルダ内のファイルたちの情報は次の段階のForEachループでゲット。）

'現在のフォルダの中「だけ」の、すべてのファイルの

'一覧の書き出し。（サブフォルダも含む）

'コメント内容は前述の「サブフォルダ延々掘り」のときと

'おおむね同じ。（フォルダ情報がファイル情報になっただけ）

'　↓　 ↓

For Each o_FileItem In FSO.GetFolder(s_folderPath).Files

myCount = myCount + 1

'◆◆◆↓ カレントフォルダの全ファイルに対して行う処理。

'◆◆◆↓ カレントフォルダに何もしないなら以下のブロックは

'◆◆◆↓ 消しても良い。

Call CurrentFolderWork01(o_ImpSheet, s_folderPath, myCount, o_FileItem)

Next o_FileItem

End Sub

'####################################################

'サブフォルダを掘るループにさせたい内容

'通常は、特にさせることはない。

'が、今回はサブフォルダの情報を知りたいので、以下のようなプログラムを書くことになる。

'引数は、TPO・目的によって、増やしたり減らしたり無くしたりする。

'また、参照渡しで、呼び出しモトの引数をそのまま引き継いでいます。

'◆◆◆ここのプロシージャはサブフォルダに対して何かするための

'◆◆◆プロシージャなので、サブフォルダに対して何もしないなら以下の

'◆◆◆コードは、FunctionやEnd Function 丸ごとを、

'◆◆◆すべてコメントアウトしても良い。

'####################################################

Function SubFolderWork01(o_ImpSheet As Worksheet, _

s_folderPath As String, _

myCount As Long, _

o_FolderItem As Object)

'◆◆◆ここのプロシージャはサブフォルダに対して何かするための

'◆◆◆プロシージャなので、サブフォルダに対して何もしないなら以下の

'◆◆◆コードは、FunctionやEnd Function 丸ごとを、

'◆◆◆すべてコメントアウトしても良い。

'オブジェクト変数「o_FolderItem」は、FSOを呼び出しモトでインスタンス化してしまっているので、

'この段階では固有型の「Folder」にはできず、総称型の「Object」にしかできない。

' With Ws01

With o_ImpSheet

.Cells(myCount, 1) = o_FolderItem.Path & "\ (DIR)" 'サブフォルダのフルパスの書込み。「(DIR)」という目印あり。

' .Cells(myCount, 1) = o_FolderItem.Path '同上。目印なし。

' .Cells(myCount, 2) = Int(o_FolderItem.Size / 1024) 'サブフォルダのKBでの容量（整数。右クリックプロパティの「サイズ」の値に合わせない。）

.Cells(myCount, 3) = o_FolderItem.Type 'オブジェクトの種類（フォルダ、××ファイル、など）

.Cells(myCount, 4) = o_FolderItem.DateCreated 'サブフォルダの作成日

.Cells(myCount, 5) = o_FolderItem.DateLastAccessed 'サブフォルダの最終アクセス日時

.Cells(myCount, 6) = o_FolderItem.DateLastModified 'サブフォルダの最終更新日

End With

'↑ファイル情報を吸い込みたいシートに、具体内容を吸い込む。

Call GetFolderAndFileListSub(o_ImpSheet, o_FolderItem.Path, myCount)

'↑サブフォルダのサブフォルダを、（再帰的に）終わるまでどんどん掘っていく。

'　サブフォルダが見つかるたびに、更に掘っていく。

End Function

'####################################################

'現在のフォルダの中でのループに、させたい内容

'通常は、こっちがメイン。

' '◆◆◆ つまり、コメントアウトしちゃダメ！

' '◆◆◆ ただし、アクティブシートに何もしない場合は

' '◆◆◆ 該当するコードは消すか修正する。

'引数は、TPO・目的によって、増やしたり減らしたり無くしたりする。

'また、参照渡しで、呼び出しモトの引数をそのまま引き継いでいます。

'####################################################

Function CurrentFolderWork01(o_ImpSheet As Worksheet, _

s_folderPath As String, _

myCount As Long, _

o_FileItem As Object)

'オブジェクト変数「o_FileItem」は、FSOを呼び出しモトでインスタンス化してしまっているので、

'この段階では固有型の「File」にはできず、総称型の「Object」にしかできない。

' With Ws01

With o_ImpSheet

.Cells(myCount, 1) = o_FileItem.Path 'ファイルのフルパスを書き込む

' .Cells(myCount, 2) = Int(o_FileItem.Size / 1024) 'ファイルの容量（整数。KB単位。プロパティの「サイズ」の値に合わせない。）

.Cells(myCount, 3) = o_FileItem.Type 'ファイルの種類

.Cells(myCount, 4) = o_FileItem.DateCreated 'ファイルの作成日

.Cells(myCount, 5) = o_FileItem.DateLastAccessed 'ファイルの最終アクセス日

.Cells(myCount, 6) = o_FileItem.DateLastModified 'ファイルの最終更新日

End With

End Function

　　
　　
★ 冒頭のコードを、「特定の拡張子の、特定の語句をファイル名に含むファイルをリストアップする例」に修正してみたもの

※対象はファイルのみ、で、フォルダに対しての情報は得ないものとする。

'
'

'
Option Explicit
 
'####################################################
'すべてのファイルとフォルダの情報を調べたい、
'その「フォルダ」と、
'その情報を吸い込みたいシートを指定する処理。
'####################################################
 
Sub GetFolderAndFileListMain02()

 
    Dim o_AnswFDialg    As FileDialog
    Dim s_PickFldPath   As String
    Dim o_ImpWs01       As Worksheet
    Dim s_KenssakuGoku  As String
    Dim s_Kakutyousi    As String

    '★ 設定部

    s_KenssakuGoku = "Q"
    '↑検索したいファイル名の語句
    
    s_Kakutyousi = "pdf"
    '↑検索したいファイルの拡張子（ドット不要）
  
    Set o_AnswFDialg = Application. _
                        FileDialog(msoFileDialogFolderPicker)
    '↑ファイル選択ダイアログを使えるように準備。
    


    Set o_ImpWs01 = ActiveWorkbook. _
                             ActiveSheet
    '↑ファイル情報を吸い込むシートをアクティブシートに指定。
    
    
    
    '★ 実動部

    If Not o_AnswFDialg.Show Then
        Exit Sub
        '↑キャンセルされたときは終わる。
    Else
        s_PickFldPath = o_AnswFDialg.SelectedItems(1)
        '↑フォルダが選択されたら、
        '　ファイル選択ダイアログのオブジェクトの
        '「SelectedItems プロパティ」にフォルダパスが
        '　自動的にゲットされるので、
        '　一時的な処理として、いったん適当な変数にそれをメモ代入。
    End If
    '↑ファイル選択ダイアログを実際に開き、
    '　フォルダが選択されたら（＝フォルダパスがゲットできたら）
    '　そのパスを一時保管して次へ行き、
    '　キャンセルされたらプログラムを終わる。


    o_ImpWs01.Cells.ClearContents
    '↑いったん、指定したシートをオールクリアして真っ白にする。
    
    
    With o_ImpWs01
        .Range("A1") = "パス"
        .Range("B1") = "容量（KB）"
        .Range("C1") = "種類"
        .Range("D1") = "作成日時"
        .Range("E1") = "アクセス日時"
        .Range("F1") = "更新日時"
    End With
    '↑指定したシートに列名（項目名）を書き込む


    Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _
                                 s_folderPath:=s_PickFldPath, _
                                 s_SearchWord:=s_KenssakuGoku, _
                                 s_Extention:=s_Kakutyousi)

    '↑リスト作成の実行。
    '　ピックアップされたフォルダバスの中を、
    '　すべてのサブフォルダのすべてのファイルを対象に、
    '　o_ImpWs01 に指定したシートにファイル情報を吸い込む（＝書き込む）。
    
    
    
End Sub



'####################################################
'実際にすべてのサブフォルダたちとファイルたちの、
'ファイルとフォルダの基本情報を、
'指定したシートに吸い込む処理。
'####################################################


 
Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _
                            s_folderPath As String, _
                            s_SearchWord As String, _
                            s_Extention As String, _
                            Optional myCount As Long = 1)

   
    Dim FSO As Object
    Dim o_FolderItem As Object
    Dim o_FileItem As Object

    

    '★ 設定部
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    '↑参照設定しなくてもFSO（FileSystemObject）を使えるようにする。

    On Error Resume Next
        
        
        
    '★ 実働部
        
    'サブフォルダを再帰的に覗いていって処理。
    For Each o_FolderItem In FSO.GetFolder(s_folderPath).subfolders
         
        '※ファイルのみでフォルダに対しての情報は得ないものとするので、
        '  ここには何も書かずに、下記のフォルダの掘り下げコードのみとする。

        Call GetFolderAndFileListSub(o_ImpSheet, o_FolderItem.Path, s_SearchWord, s_Extention, myCount)
        '↑サブフォルダのサブフォルダを、（再帰的に）終わるまでどんどん掘っていく「だけ」の処理。
        '　サブフォルダが見つかるたびに、更に掘っていく。

    Next o_FolderItem
    '↑「サブフォルダのみを延々と深く最後まで掘っていくループ
    '　（この段階ではサブフォルダのフォルダ情報のみをゲット。
    '　　サブフォルダ内のファイルたちの情報は次の段階のForEachループでゲット。）
'

       

    '現在のフォルダの中「だけ」の、ファイル一覧の書き出し。（サブフォルダも含む）
    'コメント内容は前述の「サブフォルダ延々掘り」のときとおおむね同じ。（フォルダ情報がファイル情報になっただけ）
    For Each o_FileItem In FSO.GetFolder(s_folderPath).Files
    
        myCount = myCount + 1


        With o_ImpSheet
            
            If FSO.GetextensionName(o_FileItem.Path) = s_Extention Then
            '↑探す対象のファイルをPDFファイルだけに固定
            'すべてのファイルが対象なら、このIF文をコメントアウト。
            
                If 1 <= InStr(1, o_FileItem.Name, s_SearchWord, vbBinaryCompare) Then
                '↑指定した語句を含むPDFファイルだけ、以下の処理。
                
                    .Cells(myCount, 1) = o_FileItem.Path
                    '↑ファイルのフルパスを書き込む
                Else
                    myCount = myCount - 1
                    '↑条件にヒットしないファイルのときに、
                    '　空の行ができてしまうのを防ぐために
                    '　「-1」しておく。
                End If
                
            Else
                myCount = myCount - 1
                    '↑条件にヒットしないファイルのときに、
                    '　空の行ができてしまうのを防ぐために
                    '　「-1」しておく。
            End If
            
        End With
        
    Next o_FileItem
        

 
End Sub
'
'




'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

Option Explicit

'####################################################

'すべてのファイルとフォルダの情報を調べたい、

'その「フォルダ」と、

'その情報を吸い込みたいシートを指定する処理。

'####################################################

Sub GetFolderAndFileListMain02()

Dim o_AnswFDialg As FileDialog

Dim s_PickFldPath As String

Dim o_ImpWs01 As Worksheet

Dim s_KenssakuGoku As String

Dim s_Kakutyousi As String

'★ 設定部

s_KenssakuGoku = "Q"

'↑検索したいファイル名の語句

s_Kakutyousi = "pdf"

'↑検索したいファイルの拡張子（ドット不要）

Set o_AnswFDialg = Application. _

FileDialog(msoFileDialogFolderPicker)

'↑ファイル選択ダイアログを使えるように準備。

Set o_ImpWs01 = ActiveWorkbook. _

ActiveSheet

'↑ファイル情報を吸い込むシートをアクティブシートに指定。

'★ 実動部

If Not o_AnswFDialg.Show Then

Exit Sub

'↑キャンセルされたときは終わる。

Else

s_PickFldPath = o_AnswFDialg.SelectedItems(1)

'↑フォルダが選択されたら、

'　ファイル選択ダイアログのオブジェクトの

'「SelectedItems プロパティ」にフォルダパスが

'　自動的にゲットされるので、

'　一時的な処理として、いったん適当な変数にそれをメモ代入。

End If

'↑ファイル選択ダイアログを実際に開き、

'　フォルダが選択されたら（＝フォルダパスがゲットできたら）

'　そのパスを一時保管して次へ行き、

'　キャンセルされたらプログラムを終わる。

o_ImpWs01.Cells.ClearContents

'↑いったん、指定したシートをオールクリアして真っ白にする。

With o_ImpWs01

.Range("A1") = "パス"

.Range("B1") = "容量（KB）"

.Range("C1") = "種類"

.Range("D1") = "作成日時"

.Range("E1") = "アクセス日時"

.Range("F1") = "更新日時"

End With

'↑指定したシートに列名（項目名）を書き込む

Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _

s_folderPath:=s_PickFldPath, _

s_SearchWord:=s_KenssakuGoku, _

s_Extention:=s_Kakutyousi)

'↑リスト作成の実行。

'　ピックアップされたフォルダバスの中を、

'　すべてのサブフォルダのすべてのファイルを対象に、

'　o_ImpWs01 に指定したシートにファイル情報を吸い込む（＝書き込む）。

End Sub

'####################################################

'実際にすべてのサブフォルダたちとファイルたちの、

'ファイルとフォルダの基本情報を、

'指定したシートに吸い込む処理。

'####################################################

Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _

s_folderPath As String, _

s_SearchWord As String, _

s_Extention As String, _

Optional myCount As Long = 1)

Dim FSO As Object

Dim o_FolderItem As Object

Dim o_FileItem As Object

'★ 設定部

Set FSO = CreateObject("Scripting.FileSystemObject")

'↑参照設定しなくてもFSO（FileSystemObject）を使えるようにする。

On Error Resume Next

'★ 実働部

'サブフォルダを再帰的に覗いていって処理。

For Each o_FolderItem In FSO.GetFolder(s_folderPath).subfolders

'※ファイルのみでフォルダに対しての情報は得ないものとするので、

' ここには何も書かずに、下記のフォルダの掘り下げコードのみとする。

Call GetFolderAndFileListSub(o_ImpSheet, o_FolderItem.Path, s_SearchWord, s_Extention, myCount)

'↑サブフォルダのサブフォルダを、（再帰的に）終わるまでどんどん掘っていく「だけ」の処理。

'　サブフォルダが見つかるたびに、更に掘っていく。

Next o_FolderItem

'↑「サブフォルダのみを延々と深く最後まで掘っていくループ

'　（この段階ではサブフォルダのフォルダ情報のみをゲット。

'　　サブフォルダ内のファイルたちの情報は次の段階のForEachループでゲット。）

'現在のフォルダの中「だけ」の、ファイル一覧の書き出し。（サブフォルダも含む）

'コメント内容は前述の「サブフォルダ延々掘り」のときとおおむね同じ。（フォルダ情報がファイル情報になっただけ）

For Each o_FileItem In FSO.GetFolder(s_folderPath).Files

myCount = myCount + 1

With o_ImpSheet

If FSO.GetextensionName(o_FileItem.Path) = s_Extention Then

'↑探す対象のファイルをPDFファイルだけに固定

'すべてのファイルが対象なら、このIF文をコメントアウト。

If 1 <= InStr(1, o_FileItem.Name, s_SearchWord, vbBinaryCompare) Then

'↑指定した語句を含むPDFファイルだけ、以下の処理。

.Cells(myCount, 1) = o_FileItem.Path

'↑ファイルのフルパスを書き込む

Else

myCount = myCount - 1

'↑条件にヒットしないファイルのときに、

'　空の行ができてしまうのを防ぐために

'　「-1」しておく。

End If

Else

myCount = myCount - 1

'↑条件にヒットしないファイルのときに、

'　空の行ができてしまうのを防ぐために

'　「-1」しておく。

End If

End With

Next o_FileItem

End Sub

　　
　　
★ 冒頭のコードを、「”すべて”の拡張子の、特定の語句をファイル名に含むファイルをリストアップする例」に修正してみたもの

※対象はファイルのみ、で、フォルダに対しての情報は得ないものとする。

'
'

'
Option Explicit
 
'####################################################
'すべてのファイルとフォルダの情報を調べたい、
'その「フォルダ」と、
'その情報を吸い込みたいシートを指定する処理。
'####################################################
 
Sub GetFolderAndFileListMain02()

 
    Dim o_AnswFDialg    As FileDialog
    Dim s_PickFldPath   As String
    Dim o_ImpWs01       As Worksheet
    Dim s_KenssakuGoku  As String
    Dim s_Kakutyousi    As String

    '★ 設定部

    s_KenssakuGoku = "."
    '↑検索したいファイル名の語句
    
'    s_Kakutyousi = "pdf"
    '↑検索したいファイルの拡張子（ドット不要）
  
    Set o_AnswFDialg = Application. _
                        FileDialog(msoFileDialogFolderPicker)
    '↑ファイル選択ダイアログを使えるように準備。
    


    Set o_ImpWs01 = ActiveWorkbook. _
                             ActiveSheet
    '↑ファイル情報を吸い込むシートをアクティブシートに指定。
    
    
    
    '★ 実動部

    If Not o_AnswFDialg.Show Then
        Exit Sub
        '↑キャンセルされたときは終わる。
    Else
        s_PickFldPath = o_AnswFDialg.SelectedItems(1)
        '↑フォルダが選択されたら、
        '　ファイル選択ダイアログのオブジェクトの
        '「SelectedItems プロパティ」にフォルダパスが
        '　自動的にゲットされるので、
        '　一時的な処理として、いったん適当な変数にそれをメモ代入。
    End If
    '↑ファイル選択ダイアログを実際に開き、
    '　フォルダが選択されたら（＝フォルダパスがゲットできたら）
    '　そのパスを一時保管して次へ行き、
    '　キャンセルされたらプログラムを終わる。


    o_ImpWs01.Cells.ClearContents
    '↑いったん、指定したシートをオールクリアして真っ白にする。
    
    
    With o_ImpWs01
        .Range("A1") = "パス"
        .Range("B1") = "容量（KB）"
        .Range("C1") = "種類"
        .Range("D1") = "作成日時"
        .Range("E1") = "アクセス日時"
        .Range("F1") = "更新日時"
    End With
    '↑指定したシートに列名（項目名）を書き込む


    Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _
                                 s_folderPath:=s_PickFldPath, _
                                 s_SearchWord:=s_KenssakuGoku, _
                                 s_Extention:=s_Kakutyousi)

    '↑リスト作成の実行。
    '　ピックアップされたフォルダバスの中を、
    '　すべてのサブフォルダのすべてのファイルを対象に、
    '　o_ImpWs01 に指定したシートにファイル情報を吸い込む（＝書き込む）。
    
    
    
End Sub



'####################################################
'実際にすべてのサブフォルダたちとファイルたちの、
'ファイルとフォルダの基本情報を、
'指定したシートに吸い込む処理。
'####################################################


 
Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _
                            s_folderPath As String, _
                            s_SearchWord As String, _
                            s_Extention As String, _
                            Optional myCount As Long = 1)

   
    Dim FSO As Object
    Dim o_FolderItem As Object
    Dim o_FileItem As Object

    

    '★ 設定部
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    '↑参照設定しなくてもFSO（FileSystemObject）を使えるようにする。

    On Error Resume Next
        
        
        
    '★ 実働部
        
    'サブフォルダを再帰的に覗いていって処理。
    For Each o_FolderItem In FSO.GetFolder(s_folderPath).subfolders
         
        '※ファイルのみでフォルダに対しての情報は得ないものとするので、
        '  ここには何も書かずに、下記のフォルダの掘り下げコードのみとする。

        Call GetFolderAndFileListSub(o_ImpSheet, o_FolderItem.Path, s_SearchWord, s_Extention, myCount)
        '↑サブフォルダのサブフォルダを、（再帰的に）終わるまでどんどん掘っていく「だけ」の処理。
        '　サブフォルダが見つかるたびに、更に掘っていく。

    Next o_FolderItem
    '↑「サブフォルダのみを延々と深く最後まで掘っていくループ
    '　（この段階ではサブフォルダのフォルダ情報のみをゲット。
    '　　サブフォルダ内のファイルたちの情報は次の段階のForEachループでゲット。）
'

       

    '現在のフォルダの中「だけ」の、ファイル一覧の書き出し。（サブフォルダも含む）
    'コメント内容は前述の「サブフォルダ延々掘り」のときとおおむね同じ。（フォルダ情報がファイル情報になっただけ）
    For Each o_FileItem In FSO.GetFolder(s_folderPath).Files
    
        myCount = myCount + 1


        With o_ImpSheet
            
            'If FSO.GetextensionName(o_FileItem.Path) = s_Extention Then
            ''↑探す対象のファイルをPDFファイルだけに固定
            ''すべてのファイルが対象なら、このIF文をコメントアウト。
            
                If 1 <= InStr(1, o_FileItem.Name, s_SearchWord, vbBinaryCompare) Then
                '↑指定した語句を含むPDFファイルだけ、以下の処理。
                
                    .Cells(myCount, 1) = o_FileItem.Path
                    '↑ファイルのフルパスを書き込む
                Else
                    myCount = myCount - 1
                    '↑条件にヒットしないファイルのときに、
                    '　空の行ができてしまうのを防ぐために
                    '　「-1」しておく。
                End If
                
            'Else
            '    myCount = myCount - 1
            '        '↑条件にヒットしないファイルのときに、
            '        '　空の行ができてしまうのを防ぐために
            '        '　「-1」しておく。
            'End If
            
        End With
        
    Next o_FileItem
        

 
End Sub
'
'




'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

Option Explicit

'####################################################

'すべてのファイルとフォルダの情報を調べたい、

'その「フォルダ」と、

'その情報を吸い込みたいシートを指定する処理。

'####################################################

Sub GetFolderAndFileListMain02()

Dim o_AnswFDialg As FileDialog

Dim s_PickFldPath As String

Dim o_ImpWs01 As Worksheet

Dim s_KenssakuGoku As String

Dim s_Kakutyousi As String

'★ 設定部

s_KenssakuGoku = "."

'↑検索したいファイル名の語句

' s_Kakutyousi = "pdf"

'↑検索したいファイルの拡張子（ドット不要）

Set o_AnswFDialg = Application. _

FileDialog(msoFileDialogFolderPicker)

'↑ファイル選択ダイアログを使えるように準備。

Set o_ImpWs01 = ActiveWorkbook. _

ActiveSheet

'↑ファイル情報を吸い込むシートをアクティブシートに指定。

'★ 実動部

If Not o_AnswFDialg.Show Then

Exit Sub

'↑キャンセルされたときは終わる。

Else

s_PickFldPath = o_AnswFDialg.SelectedItems(1)

'↑フォルダが選択されたら、

'　ファイル選択ダイアログのオブジェクトの

'「SelectedItems プロパティ」にフォルダパスが

'　自動的にゲットされるので、

'　一時的な処理として、いったん適当な変数にそれをメモ代入。

End If

'↑ファイル選択ダイアログを実際に開き、

'　フォルダが選択されたら（＝フォルダパスがゲットできたら）

'　そのパスを一時保管して次へ行き、

'　キャンセルされたらプログラムを終わる。

o_ImpWs01.Cells.ClearContents

'↑いったん、指定したシートをオールクリアして真っ白にする。

With o_ImpWs01

.Range("A1") = "パス"

.Range("B1") = "容量（KB）"

.Range("C1") = "種類"

.Range("D1") = "作成日時"

.Range("E1") = "アクセス日時"

.Range("F1") = "更新日時"

End With

'↑指定したシートに列名（項目名）を書き込む

Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _

s_folderPath:=s_PickFldPath, _

s_SearchWord:=s_KenssakuGoku, _

s_Extention:=s_Kakutyousi)

'↑リスト作成の実行。

'　ピックアップされたフォルダバスの中を、

'　すべてのサブフォルダのすべてのファイルを対象に、

'　o_ImpWs01 に指定したシートにファイル情報を吸い込む（＝書き込む）。

End Sub

'####################################################

'実際にすべてのサブフォルダたちとファイルたちの、

'ファイルとフォルダの基本情報を、

'指定したシートに吸い込む処理。

'####################################################

Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _

s_folderPath As String, _

s_SearchWord As String, _

s_Extention As String, _

Optional myCount As Long = 1)

Dim FSO As Object

Dim o_FolderItem As Object

Dim o_FileItem As Object

'★ 設定部

Set FSO = CreateObject("Scripting.FileSystemObject")

'↑参照設定しなくてもFSO（FileSystemObject）を使えるようにする。

On Error Resume Next

'★ 実働部

'サブフォルダを再帰的に覗いていって処理。

For Each o_FolderItem In FSO.GetFolder(s_folderPath).subfolders

'※ファイルのみでフォルダに対しての情報は得ないものとするので、

' ここには何も書かずに、下記のフォルダの掘り下げコードのみとする。

Call GetFolderAndFileListSub(o_ImpSheet, o_FolderItem.Path, s_SearchWord, s_Extention, myCount)

'↑サブフォルダのサブフォルダを、（再帰的に）終わるまでどんどん掘っていく「だけ」の処理。

'　サブフォルダが見つかるたびに、更に掘っていく。

Next o_FolderItem

'↑「サブフォルダのみを延々と深く最後まで掘っていくループ

'　（この段階ではサブフォルダのフォルダ情報のみをゲット。

'　　サブフォルダ内のファイルたちの情報は次の段階のForEachループでゲット。）

'現在のフォルダの中「だけ」の、ファイル一覧の書き出し。（サブフォルダも含む）

'コメント内容は前述の「サブフォルダ延々掘り」のときとおおむね同じ。（フォルダ情報がファイル情報になっただけ）

For Each o_FileItem In FSO.GetFolder(s_folderPath).Files

myCount = myCount + 1

With o_ImpSheet

'If FSO.GetextensionName(o_FileItem.Path) = s_Extention Then

''↑探す対象のファイルをPDFファイルだけに固定

''すべてのファイルが対象なら、このIF文をコメントアウト。

If 1 <= InStr(1, o_FileItem.Name, s_SearchWord, vbBinaryCompare) Then

'↑指定した語句を含むPDFファイルだけ、以下の処理。

.Cells(myCount, 1) = o_FileItem.Path

'↑ファイルのフルパスを書き込む

Else

myCount = myCount - 1

'↑条件にヒットしないファイルのときに、

'　空の行ができてしまうのを防ぐために

'　「-1」しておく。

End If

'Else

' myCount = myCount - 1

' '↑条件にヒットしないファイルのときに、

' '　空の行ができてしまうのを防ぐために

' '　「-1」しておく。

'End If

End With

Next o_FileItem

End Sub

MENU

★ 指定したフォルダ内の、すべてのサブフォルダを延々と掘っていって、『すべてのファイルとすべてのサブフォルダ』の基本情報を指定したシートにゲットする（吸い込む）プログラム。（再帰的な処理）

関連記事

最近の投稿

カテゴリー

MENU

★ 指定したフォルダ内の、すべてのサブフォルダを延々と掘っていって、『 すべてのファイルとすべてのサブフォルダ 』の基本情報を指定したシートにゲットする（吸い込む）プログラム。（再帰的な処理）

関連記事

最近の投稿

カテゴリー

タグ

★ 指定したフォルダ内の、すべてのサブフォルダを延々と掘っていって、『すべてのファイルとすべてのサブフォルダ』の基本情報を指定したシートにゲットする（吸い込む）プログラム。（再帰的な処理）