Macro listado archivos de una carpeta

hola, felipe !

Me gustaria saber si alguno conoce una macro en Excel (VBA)
que permita obtener un listado de los ficheros que contiene una carpeta...

el siguiente es un ejemplo para rescatar los nombres de archivos en una carpeta
no requiere de macros y puede ser optimizado segun otro tipo de necesidades/opticas/...

1) escribe en la fila 1 (p.e. A1) la ruta a tu carpeta y el tipo de archivos que necesitas rescatar
(p.e.) c:\mis documentos\*.xls (solo archivos de excel) o: c:\mis documentos\*.* (todo tipo de archivos) o: ???

2) ve a (menu) insertar / nombre / definir...
a) nombre: Mis_archivos
en el cuadro de edicion: se refiere a:... escriba la siguiente macro-funcion del (viejo ?) excel v4
b) =archivos(!a$1)&repetir("",0*hoy())
TOMA nota del signo "!"
y considera que mi sistema usa como separador de argumentos a la coma ','

3) introduce la siguiente formula en la celda inferior a la carpeta (p.e. A1)
=contara(mis_archivos)

4) introduce la siguiente formula en la siguiente fila misma columna (p.e. A3)
=si(fila(a1)>a$2,"",indice(mis_archivos,fila(a1)))
-> copia/arrastra/... la formula anterior hacia abajo (al menos) tantas filas como archivos indicados en la fila 2

5) si necesitas rescatar archivos de varias carpetas... solo repite los pasos 1, 3 y 4 (el 2 ya no) en otra/s columna/s

6) si requieres manipular el resultado de lo anterior en otro tipo de listados... (copiar y pegar valores, ordenar, ???)

si cualquier duda (o informacion adicional)... comentas ?
saludos,
hector.

Hola Felipe:
Estaba intentando enviarte un libro de excel que hace lo que necesitas pero
me temo que pesa demasiado (mas de 7 megas) y no creo que pueda enviartelo.
Confirmado, no he podido adjuntarlos y no sé como se sube a una página donde
descargarlo
Por ese motivo escribo otro mensaje para indicarte otra manera de obtener
dicha utilidad. A mi me sirve extraordinariamente, incluso para abrir los
archivos mediante un hipervinculo que también te crea
Este código lo he tomado del foro y no recuerdo los autores, (quizás Héctor
Miguel pueda recordar quines son y darles la publicidad que merecen) ... yo
solo he intervenido un poquito para redondear la utilidad

En un libro de excel, Hoja1, columna F, creas dos botones para asignarles
una macro a cada uno:
Boton 1 (puedes llamarlo, por ejemplo, "Listar archivos") y asignarle una de
las macros, llamada "ListarFicheros" que verás en el código mas abajo.
Boton 2 (puedes llamarlo, por ejemplo "Borrar antes de listar") y asignarle
la macro, "borrar datoscolumnaA_E" que verás mas abajo.
Ante de esto, pulsa Alt+F11 y abre un modulo normal (modulo1) para pegar el
siguiente código :

Sub borrardatoscolumnasA_E()
'
' borrardatoscolumnasA_E Macro
' Macro grabada el 05/11/2004 por hes040
Columns("A:E").Select
Selection.ClearContents
ActiveSheet.Range("A1").Select

End Sub

Ahora en otro modulo (Modulo2) pega el siguiente código (de arriba a abajo,
es decir todo)

Option Explicit

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Public wksH As Worksheet
Public lngContFila As Long
Public strExtensión As String

Private Function GetDirectory(Optional Mensaje As String) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

'Directorio raíz (escritorio)
bInfo.pidlRoot = 0&

'Título para el diálogo
If IsMissing(Mensaje) Then
bInfo.lpszTitle = "Seleccionar un directorio"
Else
bInfo.lpszTitle = Mensaje
End If

'Tipo del directorio a devolver
bInfo.ulFlags = &H1

'Presentar el diálogo
x = SHBrowseForFolder(bInfo)

'Analizar el resultado
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function


Sub ListarFicheros()
Set wksH = Worksheets("Hoja1") 'Hoja donde se mostrarán los ficheros

Dim fso As Object, fCarpeta As Object, tmpCarpeta As Object
Dim Fichero As Object, tmpFichero As Object
Dim strRutaInicial As String

strRutaInicial = GetDirectory("Seleccionar el directorio a partir del
cual comenzará el listado.")
If strRutaInicial = "" Then Exit Sub
strExtensión = LCase(Application.InputBox(prompt:="Si desea que sólo se
listen los ficheros con una extensión determinada, introdúzcala sin el punto
(deje en blanco para que se listen todos los ficheros)", Type:=2))

Set fso = CreateObject("Scripting.FileSystemObject")
Set fCarpeta = fso.GetFolder(strRutaInicial)

wksH.Range("A1") = "Ruta"
wksH.Range("B1") = "Nombre"
wksH.Range("C1") = "Tamaño"
wksH.Range("D1") = "Fecha Modif."
wksH.Range("E1") = "Nombre largo"

lngContFila = 2

Application.ScreenUpdating = False

For Each tmpFichero In fCarpeta.Files
If strExtensión = "" Or LCase(fso.getextensionname(tmpFichero)) =
strExtensión Then
wksH.Cells(lngContFila, 1) = fCarpeta.path
wksH.Cells(lngContFila, 2) = tmpFichero.ShortName
wksH.Cells(lngContFila, 3) = tmpFichero.Size
wksH.Cells(lngContFila, 4) = tmpFichero.DateLastModified
wksH.Cells(lngContFila, 5) = tmpFichero.Name

lngContFila = lngContFila + 1
If lngContFila > 65535 Then
MsgBox prompt:="Demasiados ficheros.", Buttons:=vbCritical +
vbOKOnly, Title:="EscribirEnArchivos"
Exit Sub
End If
End If

Next tmpFichero

Set tmpFichero = Nothing
Set Fichero = Nothing
Set tmpCarpeta = Nothing
Set fCarpeta = Nothing
Set fso = Nothing

EscribirArchivos2 strRutaInicial

With wksH
.Range("A1:E1").HorizontalAlignment = xlCenter
.Range("A1:E1").Font.Bold = True
.Cells(lngContFila, 3).Formula = "=SUM(C2:B" & lngContFila - 1 & ")"
.Range("C2:C" & lngContFila).NumberFormat = "#,##0"
.Range("D2:D" & lngContFila).NumberFormat = "dd-mm-yy hh:mm:ss"
End With

Application.ScreenUpdating = True

wksH.Columns("A:E").AutoFit

Set wksH = Nothing
End Sub

Private Sub EscribirArchivos2(RutaInicial As String)

On Error GoTo ManejoErrores

Dim fso As Object, fCarpeta As Object, tmpCarpeta As Object
Dim Fichero As Object, tmpFichero As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set fCarpeta = fso.GetFolder(RutaInicial)

For Each tmpCarpeta In fCarpeta.SubFolders
For Each tmpFichero In tmpCarpeta.Files
If strExtensión = "" Or LCase(fso.getextensionname(tmpFichero))
= strExtensión Then
wksH.Cells(lngContFila, 1) = tmpCarpeta.path
wksH.Cells(lngContFila, 2) = tmpFichero.ShortName
wksH.Cells(lngContFila, 3) = tmpFichero.Size
wksH.Cells(lngContFila, 4) = tmpFichero.DateLastModified
wksH.Cells(lngContFila, 5) = tmpFichero.Name

lngContFila = lngContFila + 1
If lngContFila > 65535 Then
Application.ScreenUpdating = True
MsgBox prompt:="Demasiados ficheros.",
Buttons:=vbCritical + vbOKOnly, Title:="EscribirEnArchivos"
Exit Sub
End If
End If

Next

EscribirArchivos2 tmpCarpeta.path

Next

Set tmpFichero = Nothing
Set Fichero = Nothing
Set tmpCarpeta = Nothing
Set fCarpeta = Nothing
Set fso = Nothing

Exit Sub

ManejoErrores:
'En Windows XP, algunos ficheros del sistema (como el de paginación)
carecen de nombre corto, por lo que hay que capturar el error que se produce
al intentar acceder a él (propiedad ShortName).
If Err.Number = 5 Then Resume Next Else MsgBox Err.Number &
Err.Description

End Sub

Bien, pulsando el botón nº 2, te listará los archivos poniendo los datos
según la siguiente lista:

("A1") = "Ruta"
("B1") = "Nombre"
("C1") = "Tamaño"
("D1") = "Fecha Modif."
("E1") = "Nombre largo"
Estos otros datos tendrás que conseguirlos escribiendo los encabezados
(fila1) y las fórmulas siguientes (fila2):

("G1") = "Hipervinculo" Poner la siguiente fórmula en G2 y copiar
hacia abajo todas las filas que desees...
=SI(A2<>"";HIPERVINCULO(A2;B2)&"\"&E2;"")

("D1") = "Terminación ó extensión de los archivos" Poner la
siguiente fórmula en G2 y copiar hacia abajo todas las filas que desees...
=SI(A2<>"";CONCATENAR("*";DERECHA(E2;4));"")

("E1") = "Primera letra del nombre del archivo" Poner la siguiente
fórmula en G2 y copiar hacia abajo todas las filas que desees...
=SI(A2<>"";IZQUIERDA(G2;1,1);"")

Espero que te funcione y te sea de gran utilidad como para mí lo es.
Saludos
José Rafael- Valencia





"felipe" escribió en el mensaje
news:

Buenas tardes
Me gustaría saber si alguno conoce una macro en Excel (VBA) que permita
obtener un listado de los ficheros que contiene una carpeta.

I would like to know if someone knows any macro that gives me a list of
all
files that I have into a directory.

Gracias y un saludo
Thanks
felipe