Lista de carpetas y subcarpetas en VBA Excel

Compatibilidad: Truco compatible con Excel 365Truco compatible con Excel 2019Truco compatible con Excel 2016Truco compatible con Excel 2013Truco compatible con Excel 2010

Podemos crear una macro que genera un listado de carpetas y subcarpetas de una determinada ruta de nuestro equipo.

Lista de carpetas y subcarpetas en VBA Excel
  • CREAR MACRO
  1. Con Excel abierto.

  2. Pulsar la tecla Alt y mantener pulsada / Pulsar la tecla F11. Mostrará el editor de Visual Basic.

  3. Ir a: Barra de Menú / Insertar / Módulo. Mostrará la ventana del módulo donde escribimos la macro.

    Explorador de Proyectos con módulo1 seleccionado
  4. Escribir el código de la macro...

  5. Guardar el libro con la extensión *.xlsm. Libro habilitado para macros.

 
  • CARPETAS EN LA RAÍZ DE LA UNIDAD

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

  1. Ejecutar la macro / Verificar como muestra la lista de carpetas situadas en la raíz de la unidad, sin mostrar la ruta.

CARPETAS EN LA RAÍZ DE LA UNIDAD
 
  • CARPETAS EN LA RAÍZ DE LA UNIDAD CON RUTA

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

  1. Ejecutar la macro / Verificar como muestra la lista de carpetas situadas en la raíz de la unidad, mostrando la ruta.

CARPETAS EN LA RAÍZ DE LA UNIDAD CON RUTA
 
  • TODAS LAS CARPETAS Y SUBCARPETAS SIN RUTA

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

  1. Ejecutar la macro / Verificar como muestra la lista de todas las carpetas, sin mostrando la ruta.

TODAS LAS CARPETAS Y SUBCARPETAS SIN RUTA
 
  • TODAS LAS CARPETAS Y SUBCARPETAS CON RUTA

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

  1. Ejecutar la macro / Verificar como muestra la lista de todas las carpetas con la ruta.

hOJA eXCEL CON TODAS LAS CARPETAS Y SUBCARPETAS CON RUTA
 
  • TODAS LAS CARPETAS Y SUBCARPETAS CON PROPIEDADES

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

  1. Ejecutar la macro / Verificar como muestra un listado de todas las carpetas, mostrando sus propiedades.

Hoja Excel con TODAS LAS CARPETAS Y SUBCARPETAS Y PROPIEDADES
Nivel de dificultad: Experto VBA-Macros Excel Experto VBA - Macros

3 comentarios en “Lista de carpetas y subcarpetas en VBA Excel

  • Aparte de que hay que corregir algunos fallos de "se esperaba End If" y similar, no funciona. Solo me crea los títulos y luego da error 5, argumento o llamada no válida, en Sub carpetasTodas, en la línea de Set oSourceFolder = oFSO.GetFolder(SourceFolder)

    • Hola Luis,

      Te recomiendo que revises el código que tengas escrito, ya que al ejecutarlo según se indica no presenta ningún problema que corregir. En alguna carpeta del sistema o protegida puede detenerse el código en oSourceFolder.Size al no poderla leer (por seguridad).

      Saludos.

Deja una respuesta

Tu dirección de correo electrónico no será publicada. Los campos obligatorios están marcados con *

Este sitio usa Akismet para reducir el spam. Aprende cómo se procesan los datos de tus comentarios.