指定されたフォルダ内のサブフォルダ名とその中のファイル名取得
Option Explicit
Option Base 1
Sub GetFolderAndFilesNameList()
Dim fso As Object
Dim fileObj As Object '取得するファイルオブジェクト
Dim folderObj As Object '取得対象のフォルダオブジェクト
Dim parentFolName As String '取得対象のフォルダ名
Dim fl As Object, f As Object 'ファイルオブジェクト
Dim r As Long, c As Long
Dim i As Integer
Dim maxNum As Long
parentFolName = ""
Set fso = CreateObject("Scripting.FileSystemObject")
'親フォルダを選択するプロシージャの呼び出し
parentFolName = GetFolderName
Set folderObj = fso.getFolder(parentFolName)
'時間計測用(開始)-------------
Dim myspeed As Double
Dim starttime As Double
starttime = Timer
'---------------------------
'シート「フォルダ_ファイル」
With ThisWorkbook.ActiveSheet
.Cells.Clear
.Cells(2, 1).Value = "フォルダ名"
.Cells(2, 2).Value = "数"
.Rows(2).Font.Bold = True
r = 3
maxNum = 0
'サブフォルダ名を取得
For Each fl In folderObj.SubFolders
.Cells(r, 1).Value = fl.Name
'サブフォルダ内のファイル名を取得
c = 3
Set fileObj = fso.getFolder(fl.Path).Files
For Each f In fileObj
.Cells(r, c).Value = f.Name
c = c + 1
Next f
.Cells(r, 2).Value = c - 3
r = r + 1
Next fl
'各行の中で列数の最大値を格納
maxNum = Application.WorksheetFunction.Max(.Columns(2))
'ファイルを格納している列に連番を入力
For i = 1 To maxNum
.Cells(2, i + 2).Value = i
Next i
.Columns(2).HorizontalAlignment = xlCenter
.Rows(2).HorizontalAlignment = xlCenter
.Range(Columns(1), Columns(maxNum + 2)).EntireColumn.AutoFit
End With
Set fso = Nothing
Set f = Nothing
Set fileObj = Nothing
Set fl = Nothing
Set folderObj = Nothing
'時間計測用(終了)-------------
myspeed = Timer - starttime
Debug.Print "2_処理時間は" & myspeed & "秒です"
'---------------------------
MsgBox "完了"
End Sub
'フォルダ選択ダイアログから、選択されたフォルダパスを取得
Function GetFolderName()
Dim folderName As String
folderName = ""
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダ選択"
If .Show = True Then
folderName = .SelectedItems(1) 'フルパス
Else
MsgBox "フォルダを選択してください"
End
End If
End With
GetFolderName = folderName
End Function
コメント