トップ　>　備忘録　>　再帰呼び出しを使用したファイルのリストアップ

Private lngUsedRow As Long, lngUsedCol As Long 'データ書込に使用するセル範囲カウント用
Private lngDireCount As Long, lngFileCount As Long 'フォルダ、ファイル数格納用
Private strDP As String, strSep As String
Private varArea As Variant
Private strDirName(1 To 3) As String

Sub Main_Sub()
    With Application.FileDialog(msoFileDialogFolderPicker)
        strDP = ""
        If .Show = True Then strDP = .SelectedItems(1) 'フォルダ選択
        If strDP = "" Then Exit Sub
    End With
        
    If File_ListUp Then 'サーチ
        MsgBox "フォルダ数：" & lngDireCount & vbCrLf & _
               "ファイル数：" & lngFileCount, _
               vbOKOnly + vbInformation, "処理完了"
    End If
    strDP = Dir("")
End Sub

Private Function File_ListUp() As Boolean
    Dim lngSep As Long, lngSC As Long
    Dim strDN As String 'フォルダ名格納用
    With Application
        strSep = .PathSeparator 'パスセパレーターの取得
        lngSep = InStrRev(strDP, strSep)
        If lngSep = 0 Then GoSub FIN_1
        If strSep = Right$(strDP, 1) Then strDP = Left$(strDP, Len(strDP) - 1)
        On Error GoTo FIN_1
            strDN = Dir(strDP, vbDirectory) 'フォルダの存在確認
        On Error GoTo 0
        If strDN = "" Then GoSub FIN_1
        If InStr(strDP, strSep) = 0 Then strDN = ""
        
        lngDireCount = 1
        lngFileCount = 0
        Call Count_Dir_File(1, 2, Left$(strDP, lngSep), strDN & strSep)
        
        lngSC = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1 'シート数を1枚に設定
        .Workbooks.Add '新しいブックの挿入
        .SheetsInNewWorkbook = lngSC
        With .ActiveWorkbook.Worksheets(1)
            If .Rows.Count < lngUsedRow Or .Columns.Count < lngUsedCol Then GoSub FIN_2
            If lngUsedRow = 0 Then lngUsedRow = 1
            If lngUsedCol < 2 Then lngUsedCol = 2
            With .Range(.Cells(1, 1), .Cells(lngUsedRow, lngUsedCol))
                varArea = .Value
                strDirName(1) = "["
                strDirName(3) = "]"
                If strDN = "" Then strDirName(2) = strDP Else strDirName(2) = strDN
                varArea(1, 1) = Join$(strDirName)
                Call ListUp_Main(2, 2, Left$(strDP, lngSep), strDN & strSep)
                .Value = varArea '書き込み
            End With
            .UsedRange.EntireColumn.ColumnWidth = 4.38
            Erase varArea
        End With
    End With
    File_ListUp = True
Exit Function
FIN_1:
    MsgBox "選択したフォルダは対象外です", vbOKOnly + vbExclamation, "中止します"
Exit Function
FIN_2:
    MsgBox "シートに表示しきれません", vbOKOnly + vbExclamation, "中止します"
End Function

'フォルダ、ファイル数のカウント用プロシージャ（再帰）
Private Sub Count_Dir_File(ByRef r As Long, ByRef c As Long, _
                            ByVal strDirPath As String, ByVal strNewDir As String)
    Dim F As Object, FSO As Object, objDirectory As Object
    On Error GoTo ERR
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set objDirectory = FSO.GetFolder(strDirPath & strNewDir)
        With objDirectory
            lngDireCount = lngDireCount + .SubFolders.Count
            If 0 < .SubFolders.Count Then 'サブフォルダの有無確認
                For Each F In .SubFolders
                    c = c + 1
                    r = r + 1
                    If lngUsedCol < c Then lngUsedCol = c
                    Call Count_Dir_File(r, c, strDirPath & strNewDir, F.Name & strSep)
                    c = c - 1
                Next
            End If
            lngFileCount = lngFileCount + .Files.Count 'ファイル数取得
            r = r + .Files.Count
            lngUsedRow = r
        End With
    On Error GoTo 0
ERR:
    Set objDirectory = Nothing
    Set FSO = Nothing
End Sub

'フォルダ、ファイル名を変数に格納するプロシージャ（再帰）
Private Sub ListUp_Main(ByRef r As Long, ByRef c As Long, _
                        ByVal strDirPath As String, ByVal strNewDir As String)
    Dim F As Object, FSO As Object, objDirectory As Object
    On Error GoTo ERR
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set objDirectory = FSO.GetFolder(strDirPath & strNewDir)
        With objDirectory
            If 0 < .SubFolders.Count Then
                For Each F In .SubFolders
                    strDirName(2) = F.Name 'フォルダ名取得
                    varArea(r, c) = Join$(strDirName)
                    c = c + 1
                    r = r + 1
                    Call ListUp_Main(r, c, strDirPath & strNewDir, F.Name & strSep)
                    c = c - 1
                Next
            End If
            If 0 < .Files.Count Then
                For Each F In .Files
                    varArea(r, c) = F.Name 'ファイル名の取得と代入
                    r = r + 1
                Next
            End If
        End With
    On Error GoTo 0
ERR:
    Set objDirectory = Nothing
    Set FSO = Nothing
End Sub

Sub UseFileDialogOpen()
    Dim lngCount As Long
    ' ファイル ダイアログを開きます。
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True 'ファイルの複数選択を可能にする
        .Show
        ' 選択された各ファイルのパスを表示します。
        For lngCount = 1 To .SelectedItems.Count
            MsgBox .SelectedItems(lngCount)
        Next lngCount
    End With
End Sub