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

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

以降に挙げたプログラムを標準モジュールに単純にALLコピペして、
「GetFolderAndFileListMain02」のほうだけを実行します。

なお、このプログラムを、他のプログラムに流用したい場合は、
「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"      
    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

Option Explicit

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

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

'その「フォルダ」と、

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

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

Sub GetFolderAndFileListMain02()

Dim o_AnswFDialg As FileDialog

Dim s_PickFldPath As String

Dim o_ImpWs01 As Worksheet

'★ 設定部

' s_FoldPath = "D:\1"

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

MENU

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

関連記事

最近の投稿

カテゴリー

MENU

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

関連記事

最近の投稿

カテゴリー

タグ

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