Como puedo listar archivos por extensión en carpetas y subcarpetas

Para Dante Amor

Buenas tardes, le explico breve mente,

Tengo una macro que lista los archivos en carpeta y subcarpetas lo que necesito es que en una celda elegir el tipo de extensión a listar.

Le agradecería mucho me pueda ayudar.

MODULO 1

Dim iRow

Sub ListFiles()

iRow = 11
Rows(iRow & ":" & "65536").Clear
Call ListMyFiles(Range("C7"), Range("C8"))
End Sub

Sub ListMyFiles(mySourcePath, IncludeSubfolders)
Set MyObject = New Scripting.FileSystemObject
Set mySource = MyObject.GetFolder(mySourcePath)
On Error Resume Next
For Each myFile In mySource.Files
iCol = 2
Cells(iRow, iCol).Value = myFile.path
iCol = iCol + 1
Cells(iRow, iCol).Value = myFile.Name
iCol = iCol + 1
Cells(iRow, iCol).Value = myFile.Size
iCol = iCol + 1
Cells(iRow, iCol).Value = myFile.DateLastModified
iRow = iRow + 1
Next
If IncludeSubfolders Then
For Each mySubFolder In mySource.SubFolders
Call ListMyFiles(mySubFolder.path, True)
Next
End If

Option Private Module
#If VBA7 And Win64 Then

Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As LongPtr
lpfn As LongPtr
lParam As LongPtr
iImage As LongPtr
End Type

'Si es de 64 bits
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
#Else
'Si es de 32 bits
Private Type BROWSEINFO ' used by the function GetFolderName
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

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
#End If

Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
#If VBA7 And Win64 Then
'Si es de 64 bits
Dim bInfo As BROWSEINFO, path As String, r As LongPtr
Dim X As LongPtr, pos As Integer
#Else
'Si es de 32 bits
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
#End If
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Seleccione una Carpeta"
' the dialog title
Else
bInfo.lpszTitle = "¿En que carpeta desea guardar el Archivo a generar?" ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1) & "\"
If Right(GetFolderName, 2) = "\\" Then GetFolderName = Left(GetFolderName, Len(GetFolderName) - 1)
Else
GetFolderName = ""
End If
End Function

Sub TestGetFolderName()
Dim FolderName As String
FolderName = GetFolderName("Select a folder")
If FolderName = "" Then
MsgBox "No has seleccionado una carpeta válida"
Range("C7").Value = "C:\"
Else
Range("C7").Value = FolderName
End If
End Sub

anexo imagen de módulos y estructura 

1 Respuesta

Respuesta
1

Para listar los archivos solamente necesitas estas macros.

Pon la extensión en la celda C9

Dim iRow
'
Sub ListFiles()
    iRow = 11
    Rows(iRow & ":" & "65536").Clear
    Call ListMyFiles(Range("C7"), Range("C8"), Range("C9"))
End Sub
'
Sub ListMyFiles(mySourcePath, IncludeSubfolders, extension)
    Set MyObject = New Scripting.FileSystemObject
    Set mySource = MyObject.GetFolder(mySourcePath)
    On Error Resume Next
    For Each myFile In mySource.Files
        If UCase(Right(myFile.Name, Len(extension))) = UCase(extension) Then
            iCol = 2
            Cells(iRow, iCol).Value = myFile.path
            iCol = iCol + 1
            Cells(iRow, iCol).Value = myFile.Name
            iCol = iCol + 1
            Cells(iRow, iCol).Value = myFile.Size
            iCol = iCol + 1
            Cells(iRow, iCol).Value = myFile.DateLastModified
            iRow = iRow + 1
        End If
    Next
    If IncludeSubfolders Then
        For Each mySubFolder In mySource.SubFolders
            Call ListMyFiles(mySubFolder.path, True, extension)
        Next
    End If
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

Sr. Dante gracias por su pronta respuesta, pero al ponerle los códigos dados me sale un error

no se si sea por en un mismo archivo estoy haciendo correr varias macros o no se a que se debe ese error.

Le agradeciera me pueda ayudar.

Slds,

es ahí donde señala el error

¿Y antes te funcionaba la macro?

Entra al menú de VBA, en herramientas, en referencias, busca la referencia "Microsoft Scripting Runtime", activa la casilla, presiona Aceptar.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

Disculpe pero no hay esa referencia mencionada, o esta con otro nombre? 

la eh buscado 3 veces y no esta :S

¿Y antes te funcionaba la macro?

si funcionaba, solo quería agregarle la extensión.. a que se debe favor de ayudarme.. please

Entonces pon la macro completa, me parece que no la pusiste bien.

Vuelve a ponerla y la reviso otra vez.

Quita la macro que yo te envié y vuelve a probar

Ok. Bueno cambie la línea por la siguiente. Códigos y me funciono.

Set MyObject = CreateObject("Scripting.FileSystemObject")

Pero me podrías decir como agrego la referencia que ud. menciona por favor.

Y le agradezco mucho por haberse dado un tiempo en responder mi consulta.

Muchas pero muchas gracias

Si la referencia no existe, deberás buscarla en la red, es un componente que viene en la versión de excel, tal vez debas actualizar excel.

R ecuerda valorar la respuesta.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas