Lista de archivos 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 archivos de una determinada ruta de nuestro equipo.

Lista de archivos 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.

 
  • ARCHIVOS EN LA RAÍZ CON RUTA

Sub Archivos_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 ficheros = directorio.Files

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

For Each archivo In ficheros
ActiveCell = ruta & archivo.Name
ActiveCell.Offset(1, 0).Select
Next

Set fs_objeto = Nothing
Set directorio = Nothing
Set ficheros = Nothing

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

Application.ScreenUpdating = True

End Sub

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

 
  • ARCHIVOS EN LA RAÍZ SIN RUTA

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 ficheros = directorio.Files

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

For Each archivo In ficheros
ActiveCell = archivo.Name
ActiveCell.Offset(1, 0).Select
Next

Set fs_objeto = Nothing
Set directorio = Nothing
Set ficheros = 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.

 
  • TODOS LOS ARCHIVOS SIN RUTA

Sub Archivos_Todos()

Application.ScreenUpdating = False

Dim datosCarpeta As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Seleccionar la carpeta"
.Show
If .SelectedItems.Count > 0 Then
datosCarpeta = .SelectedItems(1) & "\"
End If
End With

With ActiveSheet
.Cells(1, 1) = "Archivos"
.Cells(1, 1).Font.Bold = True
End With

Call LoopFolders(datosCarpeta)

End Sub

 

Sub LoopFolders (strFolderPath As String)

Dim objFileSystem As Object
Dim objFolder As Object
Dim objFile As Object
Dim nLastRow As Integer

Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileSystem.GetFolder(strFolderPath)

For Each objFile In objFolder.Files
With ActiveSheet
nLastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & nLastRow) = objFile.Name
End With
Next

If objFolder.subfolders.Count > 0 Then
For Each objSubFolder In objFolder.subfolders
If ((objSubFolder.Attributes And 2) = 0) And ((objSubFolder.Attributes And 4) = 0) Then
LoopFolders (objSubFolder.Path)
End If
Next
End If

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

Application.ScreenUpdating = True

End Sub

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

 
  • TODOS LOS ARCHIVOS CON RUTA

Sub Archivo_todos_Ruta()

Application.ScreenUpdating = False

Dim datosCarpeta As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Seleccionar la carpeta"
.Show
If .SelectedItems.Count > 0 Then
datosCarpeta = .SelectedItems(1) & "\"
End If
End With

With ActiveSheet
.Cells(1, 1) = "Archivos"
.Cells(1, 1).Font.Bold = True
End With

Call LoopFolders(datosCarpeta)

End Sub

 

Sub LoopFolders (strFolderPathAs String)

Dim objFileSystem As Object
Dim objFolder As Object
Dim objFile As Object
Dim nLastRow As Integer

Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileSystem.GetFolder(strFolderPath)

For Each objFile In objFolder.Files
With ActiveSheet
nLastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & nLastRow) = objFile.Path
End With
Next

If objFolder.subfolders.Count > 0 Then
For Each objSubFolder In objFolder.subfolders
If ((objSubFolder.Attributes And 2) = 0) And ((objSubFolder.Attributes And 4) = 0) Then
LoopFolders (objSubFolder.Path)
End If
Next
End If

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

Application.ScreenUpdating = True

End Sub

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

 
  • TODOS LOS ARCHIVOS CON HIPERVÍNCULO

Sub Archivos_ruta_link()

Dim fs_objeto As Object
Dim directorio As String
Dim dir_Archivo As Variant

Set dir_Archivo = Application.FileDialog(msoFileDialogFolderPicker)
dir_Archivo.Show

If dir_Archivo.SelectedItems.Count = 0 Then
Exit Sub
End If

With ActiveSheet
.Cells(1, 1) = "Archivos"
.Cells(1, 1).Font.Bold = True

End With

directorio = dir_Archivo.SelectedItems(1)
Set fs_objeto = CreateObject("Scripting.FileSystemObject")

Carpeta fs_objeto.GetFolder(directorio)

End Sub

 

Function Carpeta(ByVal nCarpeta)

Dim j As Long
Dim Subcarpeta As Object

With ActiveSheet

For Each Subcarpeta In nCarpeta.subfolders
Carpeta Subcarpeta
Next

j = Application.CountA(.Range("A:A")) + 1

For Each file In nCarpeta.Files
.Cells(j, 1).Select
.Hyperlinks.Add Anchor:=Selection, Address:=file.Path, TextToDisplay:=file.Path
j = j + 1
Next
End With

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

End Function

  1. Ejecutar la macro / Verificar como muestra la lista de archivos con hipervínculo.

 
  • ARCHIVOS PROPIEDADES

Sub Archivos_propiedades()

Dim strWindowsFolder As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Seleccionar la carpeta"
.Show
If .SelectedItems.Count > 0 Then
strWindowsFolder = .SelectedItems(1) & "\"
End If
End With

With ActiveSheet
.Cells(1, 1) = "Nombre"
.Cells(1, 1).Font.Bold = True
.Cells(1, 2) = "Ruta"
.Cells(1, 2).Font.Bold = True
.Cells(1, 3) = "Tamaño"
.Cells(1, 3).Font.Bold = True
.Cells(1, 4) = "Tipo Archivo"
.Cells(1, 4).Font.Bold = True
.Cells(1, 5) = "Fecha creación"
.Cells(1, 5).Font.Bold = True
End With

Call LoopFolders(strWindowsFolder)

End Sub

 

Sub LoopFolders(strFolderPath As String)

Dim objFileSystem As Object
Dim objFolder As Object
Dim objFile As Object
Dim nLastRow As Integer

Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileSystem.GetFolder(strFolderPath)

For Each objFile In objFolder.Files
With ActiveSheet
nLastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & nLastRow) = objFile.Name
.Range("B" & nLastRow) = objFile.Path
.Range("C" & nLastRow) = objFile.Size
.Range("D" & nLastRow) = objFile.Type
.Range("E" & nLastRow) = objFile.datecreated
.Columns("A:E").AutoFit
End With
Next

If objFolder.subfolders.Count > 0 Then
For Each objSubFolder In objFolder.subfolders
If ((objSubFolder.Attributes And 2) = 0) And ((objSubFolder.Attributes And 4) = 0) Then
LoopFolders (objSubFolder.Path)
End If
Next
End If

End Sub

  1. Ejecutar la macro / Verificar como muestra la lista de archivos con las propiedades en columna (nombre, ruta, tamaño, tipo y fecha creación.

 
  • ARCHIVOS FILTRADOS POR EXTENSIÓN

Sub Archivo_Extensión()

Application.ScreenUpdating = False

Dim ruta, archivos As String
Dim i As Integer

ruta = MiRuta2

archivos = Dir(ruta & "\*.xls*")

ActiveSheet.Range("A2:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row) = ""
i = 2
Do While Len(archivos) > 0
ActiveSheet.Cells(i, 1) = archivos
archivos = Dir()
i = i + 1
Loop

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

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

Application.ScreenUpdating = True

End Sub

 

Function MiRuta2()

Dim directorio As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Seleccionar Carpeta"
.Show
directorio = .SelectedItems(1)
End With

If directorio <> "" Then
MiRuta2 = directorio
End If

End Function

archivos = Dir(ruta & "\*.xls*"). Indica la extensión deseada.

  1. Ejecutar la macro / Verificar como muestra la lista de archivos con la extensión deseada, en el ejemplo .xls* para Excel.

Nivel de dificultad: Experto VBA-Macros Excel Experto VBA - Macros

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.