Problema con macro para generar listados de directorios

Buenas tardes.

Estoy buscando una macro que me genere un listado de las subcarpetas que tiene un directorio, el cual indico en una celda determinada. Actualmente, he encontrado esta que se adapta bien a mis necesidades:

Option Explicit
Sub Auto_open()
Call ListaCarpetas(Cells(1, 2).Value) 'ruta inicial
End Sub
Sub ListaCarpetas(RUTA As String)
'Lista las carpetas a partir de la ruta origen en la columna A, desde A2
Dim nom As String 'nombre del directorio
Dim aux As String
Dim i As Integer
'limpio columna A y dejo el encabezado como estaba
Range("A:A").Clear
With Range("A1")
.Font.ColorIndex = 2
.HorizontalAlignment = xlRight
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
End With
Range("A1").Value = "Ruta: " 'coloco de nuevo el titulo
If (Right(RUTA, 1) <> "\") Then RUTA = RUTA + "\" 'solo para windows
nom = Dir(RUTA, vbDirectory)
i = 1
Do While nom <> ""
If (nom <> ".") And (nom <> "..") Then 'quito las referencias al actual y superior
aux = RUTA & nom
If (GetAttr(aux) And vbDirectory) = vbDirectory Then
i = i + 1
aux = "file:///" & RUTA & nom
Hoja2.Hyperlinks.Add Anchor:=Range("A" & i), Address:=aux
End If
End If
nom = Dir ' siguiente entrada
Loop
End Sub

El problema lo tengo en que esta macro me devuelve la ruta completa de cada directorio que tengo, cuando lo que necesito es que solamente me devuelva el nombre de las carpetas, ya que el resultado de este macro lo quiero meter en una lista desplegable de otra celda, para hacer una selección de la misma.

Muchas gracias por la ayuda. Saludos.

Juan Carlos.