指定したフォルダ内のサブフォルダ名を取得

Option Explicit
Option Base 1

Sub GetFolderNameList()
   Dim fso As Object
   Dim pfl As Object
   Dim fl As Object
   Dim n As Long
   Dim pFolderName As String
  
   Set fso = CreateObject("Scripting.FileSystemObject")
   
   '取得したい親フォルダ名を取得
   pFolderName = GetFolderName
   Set pfl = fso.GetFolder(pFolderName)
   
   n = 1
   With ThisWorkbook.ActiveSheet
      .Cells.Clear
      
      ' サブフォルダの一覧を取得
      For Each fl In pfl.SubFolders
          .Range("A" & n).Value = fl.Name
          n = n + 1
      Next fl
    
    .Columns("A:A").EntireColumn.AutoFit
    .Range("A1").Select
   End With
   
   Set pfl = Nothing
   Set fso = Nothing
   
   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