フォルダに含まれるサブフォルダのリストを作成

Sub prcListSubfolders()
    Dim dlgFolder As FileDialog ' フォルダ選択用のダイアログ
    Dim strFolderPath As String ' 選択されたフォルダのパス
    Dim fsoFileSystem As FileSystemObject ' ファイルシステムオブジェクト
    Dim fldSelected As Folder ' 選択されたフォルダ
    Dim fldSubfolder As Folder ' サブフォルダ
    Dim wsTarget As Worksheet ' 出力対象のワークシート
    Dim lngRow As Long ' 出力行番号

    ' ワークシート設定
    Set wsTarget = ThisWorkbook.Sheets("フォルダリスト")
    wsTarget.Range("A2:B" & wsTarget.Rows.Count).ClearContents ' 1行目以外をクリア

    ' ファイルダイアログの設定
    Set dlgFolder = Application.FileDialog(msoFileDialogFolderPicker)
    dlgFolder.Title = "フォルダを選択してください"
    If dlgFolder.Show = -1 Then
        strFolderPath = dlgFolder.SelectedItems(1)
    Else
        Exit Sub ' ユーザーがキャンセルした場合は処理を終了
    End If

    ' FileSystemObjectの初期化
    Set fsoFileSystem = New FileSystemObject
    Set fldSelected = fsoFileSystem.GetFolder(strFolderPath)

    ' サブフォルダの情報をExcelに出力
    lngRow = 2 ' 項目タイトルがあるため、2行目から開始
    For Each fldSubfolder In fldSelected.SubFolders
        wsTarget.Cells(lngRow, 1).Value = fldSelected.Path ' 親フォルダのパス
        wsTarget.Cells(lngRow, 2).Value = fldSubfolder.Name ' サブフォルダ名
        lngRow = lngRow + 1
    Next fldSubfolder

    ' オブジェクトの解放
    Set fsoFileSystem = Nothing
    Set dlgFolder = Nothing
End Sub