List of Folders

This seems to work

Sub Test()
Dim fs, f, r
Set fs = CreateObject("Scripting.FileSystemObject")


FolderName = Dir(ThisWorkbook.Path & "\", vbDirectory)
Do While FolderName <> ""
    On Error Resume Next
    Set f = fs.GetFile(fs.GetFileName(FolderName))
    If FolderName <> f.Name Then
        N = N + 1
        Cells(N, 1) = FolderName
    End If
    FolderName = Dir()
Loop
End Sub