lista de directorios

Hola :)

... como en las filas de la columna ir agregando todos los path de directorios de la unidad c
por ej
c:\
c:\directorio1
c:\directorio2
c:\directorio2\subdirectorio2_1 [...]

copia las lineas de codigo que adjunto al final y 'corre' unas pruebas =>solo<= ...
1) agrega una referencia en el proyecto a la libreria =>Microsoft Scripting Runtime< [C:\Windows\System\ScrRun.dll]
=> en el editor de vba ... herramientas -> referencias
2) la macro 'limpia' las columnas [enteras] de la celda 'activa' y 'la siguiente' [derecha]
3) 'escribe' [desde la celda activa] un listado de directorios 'a partir' de la ruta especificada
[yo use para el ejemplo =>"D:\"<=]
=>puede ser 'a partir de' un [sub]directorio o una unidad logica 'completa' [raiz]<4) la lista se obtiene 'tal cual' estan 'depositados' en el disco duro [posiblemente 'desordenados']
5) [opcionalmente] al final podras elegir un orden 'diferente'

Saludos,
Héctor.
==> no olvides la referencia a la libreria Microsoft Scripting Runtime <= en un modulo de codigo 'normal' ==Public fso As New FileSystemObject, Carpeta As Folder, SubCarpeta As Folders, _
Sub_Dir As Variant, TotalCarpetas As Integer, Elemento As Integer, _
Carpetas() As Variant, Matriz() As Variant
Sub ListarCarpetas(): Application.ScreenUpdating = False
Dim Iniciar_en As String, Ordenar As Integer
Iniciar_en = "D:\"
Elemento = 0: Range(ActiveCell, ActiveCell.Offset(, 1)).EntireColumn.ClearContents
ActiveCell = "Existen " & ContarCarpetas(Iniciar_en) & " subcarpetas en " & Iniciar_en
For Elemento = 1 To UBound(Carpetas): ActiveCell.Offset(Elemento) = Carpetas(Elemento): Next
ActiveCell.EntireColumn.AutoFit: Application.ScreenUpdating = True
Ordenar = MsgBox("¿Deseas ordenar 'diferente' el resultado?" & vbCr & _
" SI -> Ordenar en 'ascendente'" & vbCr & _
"NO -> Ordenar en 'descendente'" & vbCr & _
"Cancelar -> Terminar la operación", _
vbQuestion + vbYesNoCancel + vbDefaultButton3, _
"Resultado de búsqueda de carpetas")
If Ordenar = vbYes Then OrdenarMatriz Carpetas
If Ordenar = vbNo Then OrdenarMatriz Carpetas, True
If Ordenar = vbCancel Then Exit Sub
ActiveCell.Offset(, 1) = "Subcarpetas ordenadas:": Application.ScreenUpdating = False
For Elemento = 0 To UBound(Matriz) - 1
ActiveCell.Offset(Elemento + 1, 1) = Matriz(Elemento)
Next: ActiveCell.Offset(, 1).EntireColumn.AutoFit
End Sub
Private Function ContarCarpetas(ByVal RutaDeInicio As String) As Integer
If Right(RutaDeInicio, 1) <> "\" Then RutaDeInicio = RutaDeInicio & "\"
On Error GoTo Horrores
Set fso = CreateObject("Scripting.FileSystemObject")
Set Carpeta = fso.GetFolder(RutaDeInicio): Set SubCarpeta = Carpeta.SubFolders
ReDim Preserve Carpetas(Elemento): Carpetas(Elemento) = Carpeta.Path
Elemento = Elemento + 1: TotalCarpetas = SubCarpeta.Count
For Each Sub_Dir In SubCarpeta
TotalCarpetas = TotalCarpetas + ContarCarpetas(RutaDeInicio & Sub_Dir.Name)
Next
FinDeFunción:
ContarCarpetas = TotalCarpetas
Set SubCarpeta = Nothing: Set Carpeta = Nothing: Set fso = Nothing: Exit Function
Horrores:
Resume FinDeFunción
End Function
Private Function OrdenarMatriz(ByVal Original As Variant, Optional ByVal Inv As Boolean) As Variant
Dim Tmp As Variant, Prov As Variant, _
Sig As Integer, Men(32) As Integer, May(32) As Integer, _
Prim As Integer, Ult As Integer, n1 As Integer, n2 As Integer
ReDim Matriz(TotalCarpetas)
For Sig = 1 To UBound(Carpetas): Matriz(Sig - 1) = Carpetas(Sig): Next
Prim = LBound(Matriz): Ult = UBound(Matriz) - 1: Sig = 1: Men(Sig) = Prim: May(Sig) = Ult
Do
If Ult > Prim Then
Prov = Matriz(Ult): n1 = Prim - 1: n2 = Ult
If Inv Then
Do
Do: n1 = n1 + 1: Loop Until Matriz(n1) <= Prov
Do: n2 = n2 - 1: Loop Until n2 = Prim Or Matriz(n2) >= Prov
Tmp = Matriz(n1): Matriz(n1) = Matriz(n2): Matriz(n2) = Tmp
Loop Until n2 <= n1
Else
Do
Do: n1 = n1 + 1: Loop Until Matriz(n1) >= Prov
Do: n2 = n2 - 1: Loop Until n2 = Prim Or Matriz(n2) <= Prov
Tmp = Matriz(n1): Matriz(n1) = Matriz(n2): Matriz(n2) = Tmp
Loop Until n2 <= n1
End If: Tmp = Matriz(n2): Matriz(n2) = Matriz(n1): Matriz(n1) = Matriz(Ult): Matriz(Ult) = Tmp: Sig = Sig + 1
If (n1 - Prim) > (Ult - n1) Then
Men(Sig) = Prim: May(Sig) = n1 - 1: Prim = n1 + 1
Else: Men(Sig) = n1 + 1: May(Sig) = Ult: Ult = n1 - 1
End If
Else: Prim = Men(Sig): Ult = May(Sig): Sig = Sig - 1: If Sig = 0 Then Exit Do
End If: Loop
End Function