★ 処理速度がOpenメソッド使用の2倍速くなる？～『いちいちExcelファイルをOpenせずに』、指定したフォルダ内の、すべてのサブフォルダを延々と掘っていって、『すべてのExcelファイルのとその中身のすべてのシート名』を、「ADO」にてアクティブシートにゲットする（吸い込む）プログラム。（再帰的な処理）

バージョン2021で作りました。

以降に挙げたプログラムを標準モジュールに単純にALLコピペして、
「GetFolderAndFileListMain02」のほうだけを実行します。
（※バージョン2000の場合はエラーになります。２００３か２００７以降なら動くかも？テストしてません。2013以降は動くと思います。）

『いちいちExcelファイルをOpenせずに』、Excelファイルのすべてのシート名をゲットしますので、Openメソッドを使う方法よりも多少なりとも速いようです。
1.5～2倍くらいは速いみたいです。

ただ、数百、数千のファイルを読み込んだ時、メモリがらみのエラーになるかどうかなどはテストしていません。
また、シート名をゲットする程度か、もしくは、ADO+SQLでなんとかなるレベルの書き換えや転記などでしか使えません。細かすぎる動きをさせたい場合は、Openメソッドを使うしかありません。
あと、パスワードがかかっているExcelファイル等々はスキップしてしまい、シートを調べることはできません。

なお、Openメソッドを使うコードとの動作速度の比較には、以下のWebページのベストアンサーのコードを使ってみてください。
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q10271440685
(「mpath = Range("B1").Value」を、「mpath = "d:\1"」など、
　実際の目的のフォルダパスに変更が必要です。あと、r=3をr=1などにも。
　一応、最下に、アクティブシートに書き出すように変えたモノがあります。)

ただし、実際のシートの並び順通りにシート名をゲットしたい場合は、遅くなっても仕方ないので、上記のURLのように、Openメソッドを使ったほうがいいようです。
本記事の方法だと、シート名が先頭文字の文字コード順に並ぶっぽいです。

ちなみにですが、上記のURLのコードだと、パスワード付きのファイル等々で、以下のようなエラーやメッセージが出ます。

(01)「××××××××××××××××××××××××.xlsxのリンク（.link拡張子）」のファイルでエラーが出て止まってします。（デバッグモードでVBEが立ち上がる場合があり。）
(02)「開いただけで勝手に内容変更がされて閉じるときに上書き保存ダイアログが出るファイル」がある。
(03)パスワードがかかっているファイルはパスワードを入力しないといけない。

など。ほかにもあるかも？

また、自分は初心者なので、シート名のゲットやらなんやらが完璧ではない可能性があります。
その際は、ご自分でも色々と試して書き換えてください。
　　

※対象はファイルのみ、で、フォルダに対しての情報は得ないものとします。
あと、Dir関数は細かく作り替えたい時にトラブルのもととなりますので、「ループ目的」としては使っていません。（サンプル程度で架空のプログラムならまだしも）

　　
※2022/12/06 追記

★かなり重要な注意事項
「Dir関数は認識できない文字（文字コード？）があるらしく、また、最悪なことに、プログラムの書き方によっては、”エラーが出てほしいところで出ない”」
という機能不足や不都合があるようです。
システムとしては致命的になってしまうので、基本的には「使わないほうが無難」なようです。

どうしても使いたいなら
『「確実にパソコン内」だけで付けたファイル名しか「絶対に・100％」ありえない』、
という前提の場合しか役に立たないようです。

また、Dir関数を使うほうが速度は４、５倍は速いようですが、一部のファイル名を認識できずにエラーになるようでは、全てのファイルやフォルダを拾えません。「４、５倍は速い」なんてものは「何の意味もない」、ということになります。

※2024/01/28追記
電帳法の関係でExcelで検索簿を作っていたら、Dir関数でのファイルの存在チェックで、「機種依存文字」が、Windows機種依存文字であるにもかかわらず、Dir関数では認識できずにエラーになる、ということがわかりました。
前述のことは、そのことを言っていたのですね・・・。勉強不足ですみません。
ですので、「全フォルダをループしてファイル名を調べて何かする、という場合は、もはやDir関数でのループは絶対に勧めてはいけない方法、ということになりました。
「絶対に機種依存文字は使いようがない」という状況の、ループ以外の場所でなら、使えます。
いずれにしましても、WebにはDir関数を使って再帰的にフォルダを掘っていくサンプルコードやQ&Aサイトでの回答がありますが、全部、真似しないようにご注意ください。FSOだけを使っているサンプルプログラムや回答だけを拾ってください。FSOは、VBEのウォッチウィンドウなどでは機種依存文字を「？」で表示していますが、実際には、ちゃんと機種依存文字を認識してくれます。

そのあたりについて詳しく書いてあるWebサイトをご紹介します。
mhtmlなどで保存しておくことをおすすめします。
VBAでファイルリストを高速に取得する関数を自作する part1
VBAでファイルリストを高速に取得する関数を自作する part2
VBAでファイルリストを高速に取得する関数を自作する part3
VBAでファイルリストを高速に取得する関数を自作する part4

↑「ファイル・フォルダリストをゲットするだけ」というシーンでしか使えないかもしれませんが、Dir関数を使うよりも何倍も速いプログラムコードも紹介されています。
もちろん、文字コードの問題もありません。
ほんと、mhtmlなどで保存しておくことをおすすめします。

あと、コメント、大幅に削りました。
エラー処理も、On Error Resume Next でごまかすのをやめて、
いちおう、On Error Goto でやりました。
（結局、設計的に正しいやり方だったのかどうかはわかりませんけど・・・）

'
'

Option Explicit


'####################################################
'すべてのファイルとフォルダの情報を調べたい、
'その「フォルダ」と、
'その情報を吸い込みたいシートを指定する処理。
'####################################################
 
Sub GetFolderAndFileListMain02()
 
 
    Dim o_AnswFDialg    As FileDialog
    Dim s_PickFldPath   As String
    Dim o_ImpWs01       As Worksheet
    

    '★ 設定部
 

    Set o_AnswFDialg = Application. _
                        FileDialog(msoFileDialogFolderPicker)
 
    Set o_ImpWs01 = ActiveWorkbook. _
                             ActiveSheet
    
    '◆◆◆↓アクティブシートに何もしないなら以下のブロックは消して良い。
    o_ImpWs01.Cells.ClearContents
    
    
    '★ 実動部
 
    If Not o_AnswFDialg.Show Then
        Exit Sub
    Else
        s_PickFldPath = o_AnswFDialg.SelectedItems(1)
    End If

 '    Call getFolderAndFileListSub(folderPath:=s_FoldPath)
 
    Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _
                                 s_folderPath:=s_PickFldPath)


    
    o_ImpWs01.Rows(1).Insert
    
    With o_ImpWs01
        .Range("A1") = "ファイル名"
        .Range("B1") = "パス"
        .Range("C1") = "シート名"
     
    End With
    '↑列名（項目名）を書き込む
    
End Sub
 
 
 
'####################################################
'実際にすべてのサブフォルダたちとファイルたちの、
'ファイルとフォルダの基本情報を、
'指定したシートに吸い込む処理。
'####################################################
 
 
 
Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _
                            s_folderPath 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")
    
'    On Error Resume Next  'ちょっとごまかしのエラー処理。

   On Error GoTo error1:   'ごまかしてないエラー処理に変えた。
        
        
    '★ 実働部
 
     For Each o_FileItem In fso.GetFolder(s_folderPath).Files
     Debug.Print o_FileItem.Name

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

    Next o_FileItem
    
    
    Debug.Print "========================================"
                
    'サブフォルダを再帰的に覗いていって処理。
    For Each o_FolderItem In fso.GetFolder(s_folderPath).SubFolders
 

'        myCount = myCount + 1
        '↑ファイル情報を吸い込みたいシートの、
        '　どの行に書き込みたいかを設定するけれど、
        '　フォルダ名も書き出す場合だけ使う。
        '　フォルダ名を書き出さない場合は、これをやると
        '　その分の1行分が空白行になるのでコメントアウトしておく。


        '◆◆◆↓ サブフォルダに何もしなくても、
        '◆◆◆↓ 消すと再帰処理で深く掘っていくことができなくなるので消したらいけない。
        Call SubFolderWork01(o_ImpSheet, s_folderPath, myCount, o_FolderItem)
 

    Next o_FolderItem

Exit Sub

error1:

    Debug.Print "GetFnFListSub" & "---" & Err.Number & "---" & Err.Description
    
    If Err.Number = 91 Then
        Resume Next
    ElseIf Err.Number = 92 Then
        Resume Next
    End If
 
 
End Sub
 
 
 
'####################################################
'サブフォルダを掘るループにさせたい内容
'通常は、特にさせることはない。
'が、サブフォルダの情報を知りたい場合は、以下のようなプログラムを書くことになる。
'引数は、TPO・目的によって、増やしたり減らしたり無くしたりする。
'また、参照渡しで、呼び出しモトの引数をそのまま引き継いでいます。
'◆◆◆ここのプロシージャはファイルではなくて
'◆◆◆「サブフォルダ自体」に対して何かするためのプロシージャなので、
'◆◆◆サブフォルダに対して何もしないなら、
'◆◆◆以下のコードは Withの中身 丸ごとを、すべてコメントアウトしても良い
'####################################################

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

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

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

        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, _
                         myCount05 As Long, _
                         o_FileItem02 As Object)
 
    Dim o_Cn        As Object
    Dim o_Ct        As Object
    Dim o_Ws01      As Object
    

On Error GoTo error1:

'    ActiveSheet.Cells(myCount05, 4) = o_FileItem02.Name
    
         '★処理対象のファイルの種類のチェック
        Dim i_Extn02    As Integer
        i_Extn02 = InStr(1, Right(o_FileItem02.Path, 5), ".xls", vbBinaryCompare)
        
        Debug.Print o_FileItem02.Path
        
        If Right(o_FileItem02.Path, 4) = ".xls" Then
'            Debug.Print "処理対象のファイル形式ではありません。"
'            GoTo Jump01:  'コメントアウトして「.xls」拡張子も対象にした。

        ElseIf 0 < i_Extn02 Then
            '拡張子がxlsxやxlsmなどだったら次へ

        Else
'            Debug.Print "処理対象のファイル形式ではありません。"
            GoTo Jump01:

        End If

    
    '★ 設定部
    
    Set o_Cn = CreateObject("ADODB.Connection")
    
    Set o_Ct = CreateObject("ADOX.Catalog")

    o_Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0" & _
                ";Data Source=" & o_FileItem02.Path & _
                ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"""
          
    o_Ct.ActiveConnection = o_Cn


    '★ 実動部
  
    For Each o_Ws01 In o_Ct.Tables

        Dim s_WsNm001 As String
        s_WsNm001 = o_Ws01.Name
                
        If Right(s_WsNm001, 1) = "$" Then
        
        ElseIf Right(s_WsNm001, 2) = "$'" Then

        Else
            GoTo Jump01
        End If
                
        
        With o_ImpSheet
        
            .Cells(myCount05, 1) = o_FileItem02.Name
            .Cells(myCount05, 2) = s_folderPath
            s_WsNm001 = Replace(s_WsNm001, "$'", "", , , vbBinaryCompare)
            s_WsNm001 = Replace(s_WsNm001, "$", "", , , vbBinaryCompare)
            s_WsNm001 = Replace(s_WsNm001, "'", "", , , vbBinaryCompare)
            .Cells(myCount05, 3) = s_WsNm001
            
            myCount05 = myCount05 + 1
            
        End With
            
Jump01:
    Next o_Ws01


    o_Cn.Close

    Set o_Ct = Nothing
    Set o_Cn = Nothing


Exit Function

error1:


    Debug.Print "CurrentFWork" & "---" & Err.Number & "---" & Err.Description
    
    If Err.Number = 91 Then
        'mp3、pdf、mdb、など、「xls文字列」を識別する分岐でハネられた、
        'Excelファイル以外のファイルの処理。
        '「オブジェクト変数または With ブロック変数が設定されていません。」エラーの処理。
        Resume Next  'エラー行に戻って次の行から続ける。
    ElseIf Err.Number = 92 Then
        'mp3、pdf、mdb、など、「xls文字列」を識別する分岐でハネられた、
        'Excelファイル以外のファイルの処理。
        '「For ループが初期化されていません。」エラーの処理。
        Resume Next  'エラー行に戻って次の行から続ける。
    
    Else
        o_Cn.Close
    
        Set o_Cn = Nothing
        Set o_Ct = Nothing
    End If
 
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

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

Option Explicit

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

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

'その「フォルダ」と、

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

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

Sub GetFolderAndFileListMain02()

Dim o_AnswFDialg As FileDialog

Dim s_PickFldPath As String

Dim o_ImpWs01 As Worksheet

'★ 設定部

Set o_AnswFDialg = Application. _

FileDialog(msoFileDialogFolderPicker)

Set o_ImpWs01 = ActiveWorkbook. _

ActiveSheet

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

o_ImpWs01.Cells.ClearContents

'★ 実動部

If Not o_AnswFDialg.Show Then

Exit Sub

Else

s_PickFldPath = o_AnswFDialg.SelectedItems(1)

End If

' Call getFolderAndFileListSub(folderPath:=s_FoldPath)

Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _

s_folderPath:=s_PickFldPath)

o_ImpWs01.Rows(1).Insert

With o_ImpWs01

.Range("A1") = "ファイル名"

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

.Range("C1") = "シート名"

End With

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

End Sub

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

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

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

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

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

Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _

s_folderPath 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")

' On Error Resume Next 'ちょっとごまかしのエラー処理。

On Error GoTo error1: 'ごまかしてないエラー処理に変えた。

'★ 実働部

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

Debug.Print o_FileItem.Name

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

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

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

Call CurrentFolderWork01(o_ImpSheet, s_folderPath, myCount, o_FileItem)

' Debug.Print myCount

Next o_FileItem

Debug.Print "========================================"

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

For Each o_FolderItem In fso.GetFolder(s_folderPath).SubFolders

' myCount = myCount + 1

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

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

'　フォルダ名も書き出す場合だけ使う。

'　フォルダ名を書き出さない場合は、これをやると

'　その分の1行分が空白行になるのでコメントアウトしておく。

'◆◆◆↓ サブフォルダに何もしなくても、

'◆◆◆↓ 消すと再帰処理で深く掘っていくことができなくなるので消したらいけない。

Call SubFolderWork01(o_ImpSheet, s_folderPath, myCount, o_FolderItem)

Next o_FolderItem

Exit Sub

error1:

Debug.Print "GetFnFListSub" & "---" & Err.Number & "---" & Err.Description

If Err.Number = 91 Then

Resume Next

ElseIf Err.Number = 92 Then

Resume Next

End If

End Sub

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

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

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

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

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

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

'◆◆◆ここのプロシージャはファイルではなくて

'◆◆◆「サブフォルダ自体」に対して何かするためのプロシージャなので、

'◆◆◆サブフォルダに対して何もしないなら、

'◆◆◆以下のコードは Withの中身丸ごとを、すべてコメントアウトしても良い

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

Function SubFolderWork01(o_ImpSheet As Worksheet, _

s_folderPath As String, _

myCount As Long, _

o_FolderItem As Object)

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

'◆◆◆サブフォルダに対して何もしないなら、

'◆◆◆以下のコードは Withの中身丸ごとを、すべてコメントアウトしても良い

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

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

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, _

myCount05 As Long, _

o_FileItem02 As Object)

Dim o_Cn As Object

Dim o_Ct As Object

Dim o_Ws01 As Object

On Error GoTo error1:

' ActiveSheet.Cells(myCount05, 4) = o_FileItem02.Name

'★処理対象のファイルの種類のチェック

Dim i_Extn02 As Integer

i_Extn02 = InStr(1, Right(o_FileItem02.Path, 5), ".xls", vbBinaryCompare)

Debug.Print o_FileItem02.Path

If Right(o_FileItem02.Path, 4) = ".xls" Then

' Debug.Print "処理対象のファイル形式ではありません。"

' GoTo Jump01: 'コメントアウトして「.xls」拡張子も対象にした。

ElseIf 0 < i_Extn02 Then

'拡張子がxlsxやxlsmなどだったら次へ

Else

' Debug.Print "処理対象のファイル形式ではありません。"

GoTo Jump01:

End If

'★ 設定部

Set o_Cn = CreateObject("ADODB.Connection")

Set o_Ct = CreateObject("ADOX.Catalog")

o_Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0" & _

";Data Source=" & o_FileItem02.Path & _

";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"""

o_Ct.ActiveConnection = o_Cn

'★ 実動部

For Each o_Ws01 In o_Ct.Tables

Dim s_WsNm001 As String

s_WsNm001 = o_Ws01.Name

If Right(s_WsNm001, 1) = "$" Then

ElseIf Right(s_WsNm001, 2) = "$'" Then

Else

GoTo Jump01

End If

With o_ImpSheet

.Cells(myCount05, 1) = o_FileItem02.Name

.Cells(myCount05, 2) = s_folderPath

s_WsNm001 = Replace(s_WsNm001, "$'", "", , , vbBinaryCompare)

s_WsNm001 = Replace(s_WsNm001, "$", "", , , vbBinaryCompare)

s_WsNm001 = Replace(s_WsNm001, "'", "", , , vbBinaryCompare)

.Cells(myCount05, 3) = s_WsNm001

myCount05 = myCount05 + 1

End With

Jump01:

Next o_Ws01

o_Cn.Close

Set o_Ct = Nothing

Set o_Cn = Nothing

Exit Function

error1:

Debug.Print "CurrentFWork" & "---" & Err.Number & "---" & Err.Description

If Err.Number = 91 Then

'mp3、pdf、mdb、など、「xls文字列」を識別する分岐でハネられた、

'Excelファイル以外のファイルの処理。

'「オブジェクト変数または With ブロック変数が設定されていません。」エラーの処理。

Resume Next 'エラー行に戻って次の行から続ける。

ElseIf Err.Number = 92 Then

'mp3、pdf、mdb、など、「xls文字列」を識別する分岐でハネられた、

'Excelファイル以外のファイルの処理。

'「For ループが初期化されていません。」エラーの処理。

Resume Next 'エラー行に戻って次の行から続ける。

Else

o_Cn.Close

Set o_Cn = Nothing

Set o_Ct = Nothing

End If

End Function

上記のコードを作るもとになったコード。
「GetFolderAndFileListSub()」にて、エラー処理をOn Error Resume Nextでごまかしていますので、あんまりいいコードではありません。

「GetFolderAndFileListMain02()」プロシージャだけを実行するのは同じです。

'
'
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
    '↑いったん、指定したシートをオールクリアして真っ白にする。
    

    
        
 
'    Call getFolderAndFileListSub(folderPath:=s_FoldPath)
 
    Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _
                                 s_folderPath:=s_PickFldPath)
 
    '↑リスト作成の実行。
    '　ピックアップされたフォルダバスの中を、
    '　すべてのサブフォルダのすべてのファイルを対象に、
    '　o_ImpWs01 に指定したシートにファイル情報を吸い込む（＝書き込む）。
    
    '◆◆◆↓アクティブシートに何もしないなら以下のブロックは消して良い。
    o_ImpWs01.Rows(1).Insert
    With o_ImpWs01
'        .Range("A1") = "パス"
'        .Range("B1") = "容量（KB）"
'        .Range("C1") = "種類"
'        .Range("D1") = "作成日時"
'        .Range("E1") = "アクセス日時"
'        .Range("F1") = "更新日時"
        .Range("A1") = "ファイル名"
        .Range("B1") = "パス"
        .Range("C1") = "シート名"
     
    End With
    '↑列名（項目名）を書き込む
    
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 '←情報を吸い込むシートも引数にしたのでコメントアウト
    
'    myCount = myCount + 1
    On Error Resume Next  'ちょっとごまかしのエラー処理。
        
        
        
    '★ 実働部
 
      
 
    '現在のフォルダの中「だけ」の、すべてのファイルの
    '一覧の書き出し。（サブフォルダも含む）
    'コメント内容は前述の「サブフォルダ延々掘り」のときと
    'おおむね同じ。（フォルダ情報がファイル情報になっただけ）
    '　↓　 ↓
    For Each o_FileItem In fso.GetFolder(s_folderPath).Files
    

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

    Next o_FileItem
                
                
    'サブフォルダを再帰的に覗いていって処理。
    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ループでゲット。）

End Sub
 
 
 
'####################################################
'サブフォルダを掘るループにさせたい内容
'通常は、特にさせることはない。
'が、サブフォルダの情報を知りたい場合は、以下のようなプログラムを書くことになる。
'引数は、TPO・目的によって、増やしたり減らしたり無くしたりする。
'また、参照渡しで、呼び出しモトの引数をそのまま引き継いでいます。
'◆◆◆ここのプロシージャはファイルではなくて
'◆◆◆「サブフォルダ自体」に対して何かするためのプロシージャなので、
'◆◆◆サブフォルダに対して何もしないなら、
'◆◆◆以下のコードは Withの中身 丸ごとを、すべてコメントアウトしても良い
'####################################################
 
Function SubFolderWork01(o_ImpSheet As Worksheet, _
                         s_folderPath As String, _
                         myCount As Long, _
                         o_FolderItem As Object)
 
        '◆◆◆ここのプロシージャはファイルではなくて
        '◆◆◆「サブフォルダ自体」に対して何かするためのプロシージャなので、
        '◆◆◆サブフォルダに対して何もしないなら、
        '◆◆◆以下のコードは Withの中身 丸ごとを、すべてコメントアウトしても良い
 
        'オブジェクト変数「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, _
                         myCount05 As Long, _
                         o_FileItem02 As Object)
 
 

    Dim o_Cn        As Object
    Dim o_Ct        As Object
    Dim o_Ws01      As Object
    

On Error GoTo error1:

'    ActiveSheet.Cells(myCount05, 4) = o_FileItem02.Name
    
         '★処理対象のファイルの種類のチェック
        Dim i_Extn02    As Integer
        i_Extn02 = InStr(1, Right(o_FileItem02.Path, 5), ".xls", vbBinaryCompare)

        If Right(o_FileItem02.Path, 4) = ".xls" Then
'            Debug.Print "処理対象のファイル形式ではありません。"
            GoTo Jump01:

        ElseIf 0 < i_Extn02 Then
            '拡張子がxlsxやxlsmなどだったら次へ

        Else
'            Debug.Print "処理対象のファイル形式ではありません。"
            GoTo Jump01:

        End If

    
    '★ 設定部
    
    Set o_Cn = CreateObject("ADODB.Connection")
    '↑設定が空の（＝未設定の）ADO用の変数の用意
    
    Set o_Ct = CreateObject("ADOX.Catalog")
    '↑設定が空の（＝未設定の）ADOX用の変数の用意


    o_Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0" & _
                ";Data Source=" & o_FileItem02.Path & _
                ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"""
    '↑対象ファイルに接続
    
           
    o_Ct.ActiveConnection = o_Cn
    '↑ADO形式で接続したExcelファイルにおいて、
    ' 「ADOX」の機能を使えるようにする。
                
'    Debug.Print myCount05
'    myCount05 = myCount05 + 1


    '★ 実動部
  
    'すべてのシート名をチェック
    For Each o_Ws01 In o_Ct.Tables
    
'

        Dim s_WsNm001 As String
        s_WsNm001 = o_Ws01.Name
                
        If Right(s_WsNm001, 1) = "$" Then
            '右端が「$」や「$'」はテーブル機能の名前定義などではなくて、
            'しっかり「シート名」なので、
            '何もしないでそのまま次へ
'            Debug.Print "aaaaa"
        ElseIf Right(s_WsNm001, 2) = "$'" Then
                '何もしないでそのまま次へ
'                Debug.Print "aaaaa"
        Else
            GoTo Jump01
        End If
        
        
        
        With o_ImpSheet
        
            .Cells(myCount05, 1) = o_FileItem02.Name
'            .Cells(myCount05, 2) = o_FileItem02.Path
            .Cells(myCount05, 2) = s_folderPath
            s_WsNm001 = Replace(s_WsNm001, "$'", "", , , vbBinaryCompare)
            s_WsNm001 = Replace(s_WsNm001, "$", "", , , vbBinaryCompare)
            .Cells(myCount05, 3) = Replace(s_WsNm001, "'", "", , , vbBinaryCompare)
            
            myCount05 = myCount05 + 1
            
        End With
            
Jump01:
    Next o_Ws01


    o_Cn.Close

    Set o_Ct = Nothing
    Set o_Cn = Nothing


Exit Function
error1:

    o_Cn.Close

    Set o_Cn = Nothing
    Set o_Ct = Nothing
    
    
'オブジェクト変数「o_FileItem02」は、FSOを呼び出しモトでインスタンス化してしまっているので、
'この段階では固有型の「File」にはできず、総称型の「Object」にしかできない。
 
 
''        With Ws01
'        With o_ImpSheet
''            .Cells(myCount05, 1) = o_FileItem02.Path                    'ファイルのフルパスを書き込む
'''            .Cells(myCount05, 2) = Int(o_FileItem02.Size / 1024)        'ファイルの容量（整数。KB単位。プロパティの「サイズ」の値に合わせない。）
''            .Cells(myCount05, 2) = Round(o_FileItem02.Size / 1024, 1)   'ファイルの容量（小数。KB単位。プロパティの「サイズ」の値に合わせる。「詳細表示」のリスト表示の「サイズ」の値とは異なります。）
''            .Cells(myCount05, 3) = o_FileItem02.Type                    'ファイルの種類
''            .Cells(myCount05, 4) = o_FileItem02.DateCreated             'ファイルの作成日
''            .Cells(myCount05, 5) = o_FileItem02.DateLastAccessed        'ファイルの最終アクセス日
''            .Cells(myCount05, 6) = o_FileItem02.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

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

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

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

' Call getFolderAndFileListSub(folderPath:=s_FoldPath)

Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _

s_folderPath:=s_PickFldPath)

'↑リスト作成の実行。

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

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

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

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

o_ImpWs01.Rows(1).Insert

With o_ImpWs01

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

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

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

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

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

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

.Range("A1") = "ファイル名"

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

.Range("C1") = "シート名"

End With

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

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 '←情報を吸い込むシートも引数にしたのでコメントアウト

' myCount = myCount + 1

On Error Resume Next 'ちょっとごまかしのエラー処理。

'★ 実働部

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

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

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

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

'　↓　 ↓

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

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

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

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

Call CurrentFolderWork01(o_ImpSheet, s_folderPath, myCount, o_FileItem)

' Debug.Print myCount

Next o_FileItem

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

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ループでゲット。）

End Sub

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

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

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

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

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

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

'◆◆◆ここのプロシージャはファイルではなくて

'◆◆◆「サブフォルダ自体」に対して何かするためのプロシージャなので、

'◆◆◆サブフォルダに対して何もしないなら、

'◆◆◆以下のコードは Withの中身丸ごとを、すべてコメントアウトしても良い

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

Function SubFolderWork01(o_ImpSheet As Worksheet, _

s_folderPath As String, _

myCount As Long, _

o_FolderItem As Object)

'◆◆◆ここのプロシージャはファイルではなくて

'◆◆◆「サブフォルダ自体」に対して何かするためのプロシージャなので、

'◆◆◆サブフォルダに対して何もしないなら、

'◆◆◆以下のコードは Withの中身丸ごとを、すべてコメントアウトしても良い

'オブジェクト変数「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, _

myCount05 As Long, _

o_FileItem02 As Object)

Dim o_Cn As Object

Dim o_Ct As Object

Dim o_Ws01 As Object

On Error GoTo error1:

' ActiveSheet.Cells(myCount05, 4) = o_FileItem02.Name

'★処理対象のファイルの種類のチェック

Dim i_Extn02 As Integer

i_Extn02 = InStr(1, Right(o_FileItem02.Path, 5), ".xls", vbBinaryCompare)

If Right(o_FileItem02.Path, 4) = ".xls" Then

' Debug.Print "処理対象のファイル形式ではありません。"

GoTo Jump01:

ElseIf 0 < i_Extn02 Then

'拡張子がxlsxやxlsmなどだったら次へ

Else

' Debug.Print "処理対象のファイル形式ではありません。"

GoTo Jump01:

End If

'★ 設定部

Set o_Cn = CreateObject("ADODB.Connection")

'↑設定が空の（＝未設定の）ADO用の変数の用意

Set o_Ct = CreateObject("ADOX.Catalog")

'↑設定が空の（＝未設定の）ADOX用の変数の用意

o_Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0" & _

";Data Source=" & o_FileItem02.Path & _

";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"""

'↑対象ファイルに接続

o_Ct.ActiveConnection = o_Cn

'↑ADO形式で接続したExcelファイルにおいて、

' 「ADOX」の機能を使えるようにする。

' Debug.Print myCount05

' myCount05 = myCount05 + 1

'★ 実動部

'すべてのシート名をチェック

For Each o_Ws01 In o_Ct.Tables

Dim s_WsNm001 As String

s_WsNm001 = o_Ws01.Name

If Right(s_WsNm001, 1) = "$" Then

'右端が「$」や「$'」はテーブル機能の名前定義などではなくて、

'しっかり「シート名」なので、

'何もしないでそのまま次へ

' Debug.Print "aaaaa"

ElseIf Right(s_WsNm001, 2) = "$'" Then

'何もしないでそのまま次へ

' Debug.Print "aaaaa"

Else

GoTo Jump01

End If

With o_ImpSheet

.Cells(myCount05, 1) = o_FileItem02.Name

' .Cells(myCount05, 2) = o_FileItem02.Path

.Cells(myCount05, 2) = s_folderPath

s_WsNm001 = Replace(s_WsNm001, "$'", "", , , vbBinaryCompare)

s_WsNm001 = Replace(s_WsNm001, "$", "", , , vbBinaryCompare)

.Cells(myCount05, 3) = Replace(s_WsNm001, "'", "", , , vbBinaryCompare)

myCount05 = myCount05 + 1

End With

Jump01:

Next o_Ws01

o_Cn.Close

Set o_Ct = Nothing

Set o_Cn = Nothing

Exit Function

error1:

o_Cn.Close

Set o_Cn = Nothing

Set o_Ct = Nothing

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

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

'' With Ws01

' With o_ImpSheet

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

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

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

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

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

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

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

' End With

End Function

前項のコードのコメントほぼ無しバージョン。
「GetFolderAndFileListMain02()」プロシージャだけを実行するのは同じです。

これも「GetFolderAndFileListSub()」にて、エラー処理をOn Error Resume Nextでごまかしていますので、あんまりいいコードではありません。

'
'
Option Explicit


'####################################################
'すべてのファイルとフォルダの情報を調べたい、
'その「フォルダ」と、
'その情報を吸い込みたいシートを指定する処理。
'####################################################
 
Sub GetFolderAndFileListMain02()
 
 
    Dim o_AnswFDialg    As FileDialog
    Dim s_PickFldPath   As String
    Dim o_ImpWs01       As Worksheet
    

    '★ 設定部
 

    Set o_AnswFDialg = Application. _
                        FileDialog(msoFileDialogFolderPicker)
 
    Set o_ImpWs01 = ActiveWorkbook. _
                             ActiveSheet
    
    '◆◆◆↓アクティブシートに何もしないなら以下のブロックは消して良い。
    o_ImpWs01.Cells.ClearContents
    
    
    '★ 実動部
 
    If Not o_AnswFDialg.Show Then
        Exit Sub
    Else
        s_PickFldPath = o_AnswFDialg.SelectedItems(1)
    End If

 '    Call getFolderAndFileListSub(folderPath:=s_FoldPath)
 
    Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _
                                 s_folderPath:=s_PickFldPath)


    
    o_ImpWs01.Rows(1).Insert
    
    With o_ImpWs01
        .Range("A1") = "ファイル名"
        .Range("B1") = "パス"
        .Range("C1") = "シート名"
     
    End With
    '↑列名（項目名）を書き込む
    
End Sub
 
 
 
'####################################################
'実際にすべてのサブフォルダたちとファイルたちの、
'ファイルとフォルダの基本情報を、
'指定したシートに吸い込む処理。
'####################################################
 
 
 
Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _
                            s_folderPath 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")
    
    On Error Resume Next  'ちょっとごまかしのエラー処理。
        
        
        
    '★ 実働部
 
     For Each o_FileItem In fso.GetFolder(s_folderPath).Files
    

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

    Next o_FileItem
                
                
    'サブフォルダを再帰的に覗いていって処理。
    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

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

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

        '◆◆◆ここのプロシージャはファイルではなくて
        '◆◆◆「サブフォルダ自体」に対して何かするためのプロシージャなので、
        '◆◆◆サブフォルダに対して何もしないなら、
        '◆◆◆以下のコードは Withの中身 丸ごとを、すべてコメントアウトしても良い

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

        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, _
                         myCount05 As Long, _
                         o_FileItem02 As Object)
 
 

    Dim o_Cn        As Object
    Dim o_Ct        As Object
    Dim o_Ws01      As Object
    

On Error GoTo error1:

'    ActiveSheet.Cells(myCount05, 4) = o_FileItem02.Name
    
         '★処理対象のファイルの種類のチェック
        Dim i_Extn02    As Integer
        i_Extn02 = InStr(1, Right(o_FileItem02.Path, 5), ".xls", vbBinaryCompare)

        If Right(o_FileItem02.Path, 4) = ".xls" Then
'            Debug.Print "処理対象のファイル形式ではありません。"
            GoTo Jump01:

        ElseIf 0 < i_Extn02 Then
            '拡張子がxlsxやxlsmなどだったら次へ

        Else
'            Debug.Print "処理対象のファイル形式ではありません。"
            GoTo Jump01:

        End If

    
    '★ 設定部
    
    Set o_Cn = CreateObject("ADODB.Connection")
    
    Set o_Ct = CreateObject("ADOX.Catalog")

    o_Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0" & _
                ";Data Source=" & o_FileItem02.Path & _
                ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"""
          
    o_Ct.ActiveConnection = o_Cn


    '★ 実動部
  
    For Each o_Ws01 In o_Ct.Tables

        Dim s_WsNm001 As String
        s_WsNm001 = o_Ws01.Name
                
        If Right(s_WsNm001, 1) = "$" Then
        
        ElseIf Right(s_WsNm001, 2) = "$'" Then

        Else
            GoTo Jump01
        End If
                
        
        With o_ImpSheet
        
            .Cells(myCount05, 1) = o_FileItem02.Name
            .Cells(myCount05, 2) = s_folderPath
            s_WsNm001 = Replace(s_WsNm001, "$'", "", , , vbBinaryCompare)
            s_WsNm001 = Replace(s_WsNm001, "$", "", , , vbBinaryCompare)
            .Cells(myCount05, 3) = Replace(s_WsNm001, "'", "", , , vbBinaryCompare)
            
            myCount05 = myCount05 + 1
            
        End With
            
Jump01:
    Next o_Ws01


    o_Cn.Close

    Set o_Ct = Nothing
    Set o_Cn = Nothing


Exit Function
error1:

    o_Cn.Close

    Set o_Cn = Nothing
    Set o_Ct = Nothing
    
           
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

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

Option Explicit

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

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

'その「フォルダ」と、

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

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

Sub GetFolderAndFileListMain02()

Dim o_AnswFDialg As FileDialog

Dim s_PickFldPath As String

Dim o_ImpWs01 As Worksheet

'★ 設定部

Set o_AnswFDialg = Application. _

FileDialog(msoFileDialogFolderPicker)

Set o_ImpWs01 = ActiveWorkbook. _

ActiveSheet

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

o_ImpWs01.Cells.ClearContents

'★ 実動部

If Not o_AnswFDialg.Show Then

Exit Sub

Else

s_PickFldPath = o_AnswFDialg.SelectedItems(1)

End If

' Call getFolderAndFileListSub(folderPath:=s_FoldPath)

Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _

s_folderPath:=s_PickFldPath)

o_ImpWs01.Rows(1).Insert

With o_ImpWs01

.Range("A1") = "ファイル名"

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

.Range("C1") = "シート名"

End With

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

End Sub

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

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

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

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

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

Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _

s_folderPath 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")

On Error Resume Next 'ちょっとごまかしのエラー処理。

'★ 実働部

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

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

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

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

Call CurrentFolderWork01(o_ImpSheet, s_folderPath, myCount, o_FileItem)

' Debug.Print myCount

Next o_FileItem

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

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

End Sub

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

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

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

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

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

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

'◆◆◆ここのプロシージャはファイルではなくて

'◆◆◆「サブフォルダ自体」に対して何かするためのプロシージャなので、

'◆◆◆サブフォルダに対して何もしないなら、

'◆◆◆以下のコードは Withの中身丸ごとを、すべてコメントアウトしても良い

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

Function SubFolderWork01(o_ImpSheet As Worksheet, _

s_folderPath As String, _

myCount As Long, _

o_FolderItem As Object)

'◆◆◆ここのプロシージャはファイルではなくて

'◆◆◆「サブフォルダ自体」に対して何かするためのプロシージャなので、

'◆◆◆サブフォルダに対して何もしないなら、

'◆◆◆以下のコードは Withの中身丸ごとを、すべてコメントアウトしても良い

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

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

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, _

myCount05 As Long, _

o_FileItem02 As Object)

Dim o_Cn As Object

Dim o_Ct As Object

Dim o_Ws01 As Object

On Error GoTo error1:

' ActiveSheet.Cells(myCount05, 4) = o_FileItem02.Name

'★処理対象のファイルの種類のチェック

Dim i_Extn02 As Integer

i_Extn02 = InStr(1, Right(o_FileItem02.Path, 5), ".xls", vbBinaryCompare)

If Right(o_FileItem02.Path, 4) = ".xls" Then

' Debug.Print "処理対象のファイル形式ではありません。"

GoTo Jump01:

ElseIf 0 < i_Extn02 Then

'拡張子がxlsxやxlsmなどだったら次へ

Else

' Debug.Print "処理対象のファイル形式ではありません。"

GoTo Jump01:

End If

'★ 設定部

Set o_Cn = CreateObject("ADODB.Connection")

Set o_Ct = CreateObject("ADOX.Catalog")

o_Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0" & _

";Data Source=" & o_FileItem02.Path & _

";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"""

o_Ct.ActiveConnection = o_Cn

'★ 実動部

For Each o_Ws01 In o_Ct.Tables

Dim s_WsNm001 As String

s_WsNm001 = o_Ws01.Name

If Right(s_WsNm001, 1) = "$" Then

ElseIf Right(s_WsNm001, 2) = "$'" Then

Else

GoTo Jump01

End If

With o_ImpSheet

.Cells(myCount05, 1) = o_FileItem02.Name

.Cells(myCount05, 2) = s_folderPath

s_WsNm001 = Replace(s_WsNm001, "$'", "", , , vbBinaryCompare)

s_WsNm001 = Replace(s_WsNm001, "$", "", , , vbBinaryCompare)

.Cells(myCount05, 3) = Replace(s_WsNm001, "'", "", , , vbBinaryCompare)

myCount05 = myCount05 + 1

End With

Jump01:

Next o_Ws01

o_Cn.Close

Set o_Ct = Nothing

Set o_Cn = Nothing

Exit Function

error1:

o_Cn.Close

Set o_Cn = Nothing

Set o_Ct = Nothing

End Function

OpenメソッドでいちいちExcelファイルを開いて処理した場合の例。
「Application.ScreenUpdating = False」を使っているのに、1.5～2倍くらい、遅いです。

ただ、シートの並びが「まんま」で出てくるのでわかりやすいです。
そのほうがいい場合は速度よりもこちらを選びます。

ただし、このコードはループ処理にDir関数を使っていて、
むやみに使うとトラブルを生む可能性がありますので、
実務にはDir関数を使わない他のサンプルコードを探すほうが
面倒に巻き込まれなくていいです。

'
'

Option Explicit



Dim sh1 As Worksheet

Dim r As Long



Sub test()

Dim mpath As String

Application.ScreenUpdating = False

Set sh1 = ActiveSheet
mpath = "d:\1"

r = 1

Call proc(mpath)

Application.ScreenUpdating = True

End Sub



Sub proc(wpath As Variant)

Dim fso As Object

Dim subfol As Variant

Dim fname As String

Dim wb As Workbook

Dim sh2 As Worksheet

fname = Dir(wpath & "\" & "*.xls*", vbNormal)

Do Until fname = ""

Set wb = Workbooks.Open(wpath & "\" & fname)

For Each sh2 In wb.Worksheets

r = r + 1

sh1.Range("A" & r).Value = fname

sh1.Range("B" & r).Value = wpath

sh1.Range("C" & r).Value = sh2.Name

Next sh2

wb.Close

fname = Dir()

Loop

Set fso = CreateObject("Scripting.FileSystemObject")

For Each subfol In fso.GetFolder(wpath).SubFolders

Call proc(subfol)

Next subfol

Set fso = Nothing

End Sub


'
'

Option Explicit

Dim sh1 As Worksheet

Dim r As Long

Sub test()

Dim mpath As String

Application.ScreenUpdating = False

Set sh1 = ActiveSheet

mpath = "d:\1"

r = 1

Call proc(mpath)

Application.ScreenUpdating = True

End Sub

Sub proc(wpath As Variant)

Dim fso As Object

Dim subfol As Variant

Dim fname As String

Dim wb As Workbook

Dim sh2 As Worksheet

fname = Dir(wpath & "\" & "*.xls*", vbNormal)

Do Until fname = ""

Set wb = Workbooks.Open(wpath & "\" & fname)

For Each sh2 In wb.Worksheets

r = r + 1

sh1.Range("A" & r).Value = fname

sh1.Range("B" & r).Value = wpath

sh1.Range("C" & r).Value = sh2.Name

Next sh2

wb.Close

fname = Dir()

Loop

Set fso = CreateObject("Scripting.FileSystemObject")

For Each subfol In fso.GetFolder(wpath).SubFolders

Call proc(subfol)

Next subfol

Set fso = Nothing

End Sub

投稿タグ: AccessVBA, Accessの独学, Access操作の基礎, Accesの独学, ExcelVBA, Excel連携VBA, マクロ, 再帰, 独学, 自動化, 高速化

MENU

関連記事

最近の投稿

カテゴリー

MENU

関連記事

最近の投稿

カテゴリー

タグ