Consulta Macro para copiar el contenido de una carpeta
Mi consulta es la siguiente, yo tengo una Macro que poniéndole la dirección de la carpeta me trae por debajo los nombre de todo su contenido. Ahora bien, lo que necesito es por ejemplo:
Tengo en cada una de las Celdas A1, B1, C1, D1, etc.. Una dirección de carpetas. Y lo que necesitaría es que la macro comience en la celda A1, me deje todos los nombres del contenido abajo y luego vaya a la celda B1 para volver a repetirse, hasta la celda que no contenga valor. (Siempre leyendo direcciones en la fila A)
Dejo la Macro que tengo, para ver si me pueden dar una mano con la modificación que haya que hacerle:
Sub Contenido_Carpeta()
'Sección 1: Variables a utilizar en la macro
Dim carpeta, archivos As String
Dim contador As Integer
'Sección 2: Lectura de carpeta y ajustes necesarios
carpeta = InputBox("Ingresa la ruta de la carpeta a importar:")
If carpeta = "" Then
Exit Sub
ElseIf Right(carpeta, 1) <> "\" Then
carpeta = carpeta & "\"
End If
'Sección 3: Preparación de variables
contador = 1
archivos = Dir(carpeta, vbDirectory)
'Sección 4: Recorrido de la carpeta
Do While Len(carpeta) > 0
If carpeta = ".." Then
contador = contador - 1
Else
ActiveSheet.Cells(contador, 1).Value = carpeta
End If
carpeta = Dir()
contador = contador + 1
Loop
End Sub
Espero puedan ayudarme, Muchísimas Gracias.
PD: Lo que realmente intento hacer es una Macro que poniendo una dirección de carpeta por Ej: (C:\...) a partir de ahí me levante todo los nombres de carpetas, sub carpetas y archivos con exención, osea, no solo el contenido de esa dirección si no que TODAS las carpetas que se encuentran a partir de ahí y pegar cada de ellas en columnas contiguas.
2 respuestas
Prueba la siguiente macro. Te pide una carpeta y a partir de esa carpeta te pone en la hoja todas las subcarpetas y los archivos de cada subcarpeta.
Dim j
Dim rutas As New Collection
Sub carpetasysub()
'por.dam
'lista archivos de una carpeta y todas las subcarpetas y todos sus archivos
'Sheets("Hoja2").Select
pPath = "C:\"
ext = "*"
'On Error Resume Next
Set n = CreateObject("shell.application")
carpeta = n.browseforfolder(0, _
"Selecciona el Directorio Inical", 0, _
pPath).items.Item.Path
If carpeta = "" Then Exit Sub
pPath = carpeta & "\"
uf = Range("C" & Rows.Count).End(xlUp).Row
If uf = 1 Then uf = 2
Range("A2:C" & uf).Clear
j = 2
rutas.Add carpeta
Call agregadir(pPath)
j = 2
For Each sd In rutas
arch = Dir(sd & "\*." & ext)
Range("B" & j) = sd
Do While arch <> ""
Range("C" & j) = arch
arch = Dir
j = j + 1
Loop
Next
Set rutas = Nothing
Columns("A:C").EntireColumn.AutoFit
MsgBox "Fin, poner archivos", vbInformation, "Directorios"
End Sub
Sub agregadir(lpath)
'Agrega directorios
Dim SubDir As New Collection
If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
DirFile = Dir(lpath & "*", vbDirectory)
Do While DirFile <> ""
'Agrega subdirectorios a collection
If DirFile <> "." And DirFile <> ".." Then _
If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then _
SubDir.Add lpath & DirFile
DirFile = Dir
Loop
For Each sd In SubDir
Range("A" & j) = sd
j = j + 1
rutas.Add sd
Call agregadir(sd)
Next
End Sub[' Si es lo que necesitas. No olvides valorar la respuesta.
Hola Dante, que tal!!
Muchísimas Gracias, esto es lo que necesitaba eres un genio!
Lo que si, te quisiera pedir un favor, la macro anda pero cada tanto me tira un error de: "nombre incorrecto", se podrá solucionar? porque se detiene y no alcanza a traerme todos los nombres..
Muchas Gracias
También en algunos casos me tira error 53 "Archivo no encontrado" (y se detienen el proceso)
Si se puede solucionar sería estupendo
A disculpa también te quería preguntar si se puede además de traer los nombres de las carpetas, traer el de los archivos por ejemplo (.xls - .xlsm - .pdf - .dwg - .jpg. - etc.).
Gracias y disculpa las molestias
La macro trae todos los archivos de todas las extensiones
Cambia esta línea
'On Error Resume Next
Por esta
On Error Resume Next
['No olvides valorar la respuesta.
Esto puede servir
Visita https://programarexcel.com
SUSCRIBE https://www.youtube.com/c/programarexcel?sub_confirmation=1