Lista de carpetas y subcarpetas en VBA Excel

Sub Carpetas_Raiz()

Application.ScreenUpdating = False
Set fs_objeto = CreateObject("Scripting.FileSystemObject")

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Seleccionar la carpeta"
.Show
End With

On Error Resume Next

ruta = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

Set directorio = fs_objeto.GetFolder(ruta)
Set subdirectorios = directorio.subfolders

Range("A1").Select
ActiveCell = "Carpetas en la raíz"
ActiveCell.Font.Bold = True
ActiveCell.Font.Underline = xlUnderlineStyleSingle
ActiveCell.Offset(1, 0).Select

For Each subdirectorio In subdirectorios
ActiveCell = subdirectorio.Name
ActiveCell.Offset(1, 0).Select
Next

Set fs_objeto = Nothing
Set Directorio = Nothing
Set subdirectorios = Nothing

Columns("A:A").EntireColumn.AutoFit
Application.ScreenUpdating = True

End Sub

Sub Carpetas_Raiz_Ruta()

Application.ScreenUpdating = False
Set fs_objeto = CreateObject("Scripting.FileSystemObject")

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Seleccionar la carpeta"
.Show
End With

On Error Resume Next

ruta = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

Set directorio = fs_objeto.GetFolder(ruta)
Set subdirectorios = directorio.subfolders

Range("A1").Select
ActiveCell = "Carpetas en la raíz"
ActiveCell.Font.Bold = True
ActiveCell.Font.Underline = xlUnderlineStyleSingle
ActiveCell.Offset(1, 0).Select

For Each subdirectorio In subdirectorios
ActiveCell = Array(subdirectorio.Path, Left(subdirectorio.Path, InStrRev(subdirectorio.Path, "\")))
ActiveCell.Offset(1, 0).Select
Next

Set fs_objeto = Nothing
Set Directorio = Nothing
Set subdirectorios = Nothing

Columns("A:A").EntireColumn.AutoFit
Application.ScreenUpdating = True

End Sub

Sub Carpetas_Todas()

Application.ScreenUpdating = False

Dim xPath As String
Dim fs_objeto As Object
Dim j As Long
Dim folder1 As Object

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Seleccionar la carpeta"
.Show
End With

On Error Resume Next

xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

Range("A1").Select
ActiveCell = "Carpetas"
ActiveCell.Font.Bold = True
ActiveCell.Font.Underline = xlUnderlineStyleSingle

ActiveCell.Cells(2, 1).Value = xPath

Set fs_objeto = CreateObject("Scripting.FileSystemObject")
Set folder1 = fs_objeto.getFolder(xPath)
getSubFolder folder1

Columns("A:A").EntireColumn.AutoFit

Application.ScreenUpdating = True

End Sub

Sub getSubFolder(ByRef prntfld As Object)

Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long

For Each SubFolder In prntfld.SubFolders
xRow = Range("A1").End(xlDown).Row + 1
Cells(xRow, 1).Resize(1, 1).Value = Mid(SubFolder, 4, 30) & "\"
Next SubFolder

For Each subfld In prntfld.SubFolders
getSubFolder subfld
Next subfld

End Sub

Sub Carpetas_Todas_ConRuta()

Application.ScreenUpdating = False

Dim xPath As String
Dim fs_objeto As Object
Dim j As Long
Dim folder1 As Object

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Seleccionar la carpeta"
.Show
End With

On Error Resume Next

xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

Range("A1").Select
ActiveCell = "Carpetas"
ActiveCell.Font.Bold = True
ActiveCell.Font.Underline = xlUnderlineStyleSingle

ActiveCell.Cells(1, 1).Resize(1, 1).Value = Array("Carpetas")
ActiveCell.Cells(2, 1).Value = xPath

Set fs_objeto = CreateObject("Scripting.FileSystemObject")
Set folder1 = fs_objeto.getFolder(xPath)
getSubFolder folder1

Columns("A:A").EntireColumn.AutoFit

Application.ScreenUpdating = True

End Sub

Sub getSubFolder(ByRef prntfld As Object)

Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long

For Each SubFolder In prntfld.SubFolders
xRow = Range("A1").End(xlDown).Row + 1
Cells(xRow, 1).Resize(1, 1).Value = Array(SubFolder.Path)
Next SubFolder

For Each subfld In prntfld.SubFolders
getSubFolder subfld
Next subfld

End Sub

Sub Carpetas_Propiedades()

Application.ScreenUpdating = False

Dim shtFldDetails As Worksheet
Dim sRootFolderName As String

Range("A1:G10000").Select
Selection.ClearContents

Range("A1").Value = "Ruta de la carpeta"
Range("B1").Value = "Ruta de carpeta corta"
Range("C1").Value = "Nombre carpeta"
Range("D1").Value = "Nombre corto de carpeta"
Range("E1").Value = "Número de subcarpetas"
Range("F1").Value = "Número de archivos"
Range("G1").Value = "Tamaño de carpeta"

Range("A1:G1").Select
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
Range("A1").Select

sRootFolderName = buscaCarpeta & "\"

If sRootFolderName = "\" Then
MsgBox "Seleccione la carpeta para buscar la lista de carpetas y subcarpetas.", vbInformation, "¡Entrada requerida!"
Exit Sub
End If

carpetasTodas sRootFolderName

Application.ScreenUpdating = True

End Sub

Sub carpetasTodas(ByVal SourceFolder As String)

Dim oFSO As Object
Dim oSourceFolder As Object
Dim oSubFolder As Object
Dim iLstRow As Integer

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oSourceFolder = oFSO.GetFolder(SourceFolder)

iLstRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row + 1

xRow = Range("A1").End(xlDown).Row + 1

With ActiveSheet
.Range("A" & iLstRow) = oSourceFolder.Path
.Range("B" & iLstRow) = oSourceFolder.ShortPath
.Range("C" & iLstRow) = oSourceFolder.Name
.Range("D" & iLstRow) = oSourceFolder.ShortName
.Range("E" & iLstRow) = oSourceFolder.SubFolders.Count
.Range("F" & iLstRow) = oSourceFolder.Files.Count
.Range("G" & iLstRow) = oSourceFolder.Size
End With

For Each oSubFolder In oSourceFolder.SubFolders
carpetasTodas oSubFolder.Path
Next oSubFolder

ActiveSheet.Columns("A:G").AutoFit

Set oSubFolder = Nothing
Set oSourceFolder = Nothing
Set oFSO = Nothing

End Sub

Public Function buscaCarpeta()

Dim FldrPicker As FileDialog
Dim myPath As String

Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
.Title = "Seleccionar carpeta"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Function
myPath = .SelectedItems(1)
End With

buscaCarpeta = myPath
If myPath = vbNullString Then Exit Function

End Function