Macro que muestre directorios y subdirectorios

Yo tengo escrito código para mostrar todos los ficheros de un directorio y de sus subdirectorios: http://www.jrgc.es/vba01.htm
He modificado el código de uno de los procedimientos para que solo muestre los directorios pero no sé si funcionará del todo bien:
Option Explicit
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
Public wksH As Worksheet
Public lngContFila As Long
Private Function GetDirectory(Optional Mensaje As String) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
    'Directorio raíz (escritorio)
    bInfo.pidlRoot = 0&
    'Título para el diálogo
    If IsMissing(Mensaje) Then
        bInfo.lpszTitle = "Seleccionar un directorio"
    Else
        bInfo.lpszTitle = Mensaje
    End If
    'Tipo del directorio a devolver
    bInfo.ulFlags = &H1
    'Presentar el diálogo
    x = SHBrowseForFolder(bInfo)
    'Analizar el resultado
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function
Sub ListarFicheros()
    Set wksH = Worksheets(1) 'Hoja donde se mostrarán los ficheros
    Dim fso As Object, fCarpeta As Object, tmpCarpeta As Object
    Dim Fichero As Object, tmpFichero As Object
    Dim strRutaInicial As String
    strRutaInicial = GetDirectory("Seleccionar el directorio a partir del cual comenzará el listado.")
    If strRutaInicial = "" Then Exit Sub
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fCarpeta = fso.GetFolder(strRutaInicial)
    'wksH.Range("A1") = "Ruta"
    'wksH.Range("B1") = "Nombre"
    'wksH.Range("C1") = "Tamaño"
    'wksH.Range("D1") = "Fecha Modif."
    'wksH.Range("E1") = "Nombre largo"
    lngContFila = 2
    Application.ScreenUpdating = False
    'For Each tmpFichero In fCarpeta.Files
        wksH.Cells(lngContFila, 1) = fCarpeta.path
        'wksH.Cells(lngContFila, 2) = tmpFichero.ShortName
        'wksH.Cells(lngContFila, 3) = tmpFichero.Size
        'wksH.Cells(lngContFila, 4) = tmpFichero.DateLastModified
        'wksH.Cells(lngContFila, 5) = tmpFichero.Name
        lngContFila = lngContFila + 1
        'If lngContFila > 65535 Then
        '    MsgBox prompt:="Demasiados ficheros.", Buttons:=vbCritical + vbOKOnly, Title:="EscribirEnArchivos"
        '    Exit Sub
        'End If
    'Next tmpFichero
    Set tmpFichero = Nothing
    Set Fichero = Nothing
    Set tmpCarpeta = Nothing
    Set fCarpeta = Nothing
    Set fso = Nothing
    EscribirArchivos2 strRutaInicial
    With wksH
        .Range("A1:E1").HorizontalAlignment = xlCenter
        .Range("A1:E1").Font.Bold = True
        .Cells(lngContFila, 3).Formula = "=SUM(C2:B" & lngContFila - 1 & ")"
        .Range("C2:C" & lngContFila).NumberFormat = "#,##0"
        .Range("D2:D" & lngContFila).NumberFormat = "dd-mm-yy hh:mm:ss"
    End With
    Application.ScreenUpdating = True
    wksH.Columns("A:E").AutoFit
    Set wksH = Nothing
End Sub
Private Sub EscribirArchivos2(RutaInicial As String)
    On Error GoTo ManejoErrores
    Dim fso As Object, fCarpeta As Object, tmpCarpeta As Object
    Dim Fichero As Object, tmpFichero As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fCarpeta = fso.GetFolder(RutaInicial)
    For Each tmpCarpeta In fCarpeta.SubFolders
        'For Each tmpFichero In tmpCarpeta.Files
            wksH.Cells(lngContFila, 1) = tmpCarpeta.path
            'wksH.Cells(lngContFila, 2) = tmpFichero.ShortName
            'wksH.Cells(lngContFila, 3) = tmpFichero.Size
            'wksH.Cells(lngContFila, 4) = tmpFichero.DateLastModified
            'wksH.Cells(lngContFila, 5) = tmpFichero.Name
            lngContFila = lngContFila + 1
            'If lngContFila > 65535 Then
            '    Application.ScreenUpdating = True
            '    MsgBox prompt:="Demasiados ficheros.", Buttons:=vbCritical + vbOKOnly, Title:="EscribirEnArchivos"
            '    Exit Sub
            'End If
        'Next
        EscribirArchivos2 tmpCarpeta.path
    Next
    Set tmpFichero = Nothing
    Set Fichero = Nothing
    Set tmpCarpeta = Nothing
    Set fCarpeta = Nothing
    Set fso = Nothing
    Exit Sub
ManejoErrores:
    'En Windows XP, algunos ficheros del sistema (como el de paginación) carecen de nombre corto, por lo que hay que capturar el error que se produce al intentar acceder a él (propiedad ShortName).
    If Err.Number = 5 Then Resume Next Else MsgBox Err.Number & Err.Description
End Sub
Hay que llamar al sub ListarFicheros, que muestra un diálogo para elegir el directorio de inicio.
Para que funcione el código es necesario haber establecido una referencia a la librería "Microsoft Scriptin Runtime", lo que se hace desde Herramientas->Referencias, estando en el editor de VBA (aunque esto parece no ser necesario en Excel 2010).