Macro que liste nombres de archivo por periodos específicos.
Ando atorado y espero que ustedes me puedan apoyar, verán, tengo una carpeta con 'n' cantidad de archivos, para esto hice una macro que me liste los nombres de los archivos .xml y .pdf para verificar contra otros datos... El problema es que la cantidad de datos es enorme... Lo que quiero es que este código únicamente aplique al periodo que yo determine, en este caso, Febrero.
Cabe resaltar que no puedo hacer subcarpetas, tengo que tomar la información de ese gran total de archivos y listarlos... Espero haberme explicado.
Anexo mi código.
Sub LasCarpetas()
'
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'
Dim NombreCarpeta As String
'
NombreCarpeta = "Y:\"
'
Call ShowFolderList(NombreCarpeta)
'
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
'
End Sub
Sub ShowFolderList(LaCarpeta As String)
'
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'
Dim NombreSubCarpeta As String
Dim lectura As String
Dim ultimo As Integer
Dim rango1, rango2 As String
Dim yo As Workbook
Dim hoja As Worksheet
'
Set yo = Workbooks("Lector")
Set hoja = Sheets("hoja1")
'
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set Folder = FileSys.GetFolder(LaCarpeta) ' Asigna la carpeta a la variable Folder
Set ListaCarpetas = Folder.Subfolders ' Asigna la lista de Subcarpetas a la variable ListaCarpetas
Set ListadoArchivos = Folder.Files ' Asigna la lista de Archivos a la variable ListadoArchivos
'
For Each Archivo In ListadoArchivos
If InStr(1, Archivo.Name, ".xml", vbTextCompare) Then
lectura = Archivo.Name
yo.Activate
End If
'
ultimo = Cells(Rows.Count, 1).End(xlUp).Row
rango1 = "A" & ultimo + 1
'
Range(rango1).Value = lectura
'
Next Archivo
'
For Each Archivo In ListadoArchivos
If InStr(1, Archivo.Name, ".pdf", vbTextCompare) Then
lectura = Archivo.Name
yo.Activate
End If
'
ultimo = Cells(Rows.Count, 5).End(xlUp).Row
rango1 = "A" & ultimo + 1
'
Range(rango1).Value = lectura
'
Next Archivo
'
MsgBox "Se ha validado la información de las facturas y xml", vbOKOnly, "Lector de archivos"
'
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
'
End Sub
Respuesta de Dante Amor
1
Si quieres los archivo en diferentes columnas:
En la columna A los xml y en la B los pdf
Sub ListarArchivos_1()
Dim a As Variant
Dim Carpeta As String
Dim sh As Worksheet
Dim ListadoArchivos As Object, archivo As Object
Dim n As Long, i As Long, j As Long
'
Carpeta = "C:\trabajo\salida"
'
Set sh = Workbooks("Lector").Sheets("Hoja1")
Set ListadoArchivos = CreateObject("Scripting.FileSystemObject").GetFolder(Carpeta).Files ' Asigna la carpeta a la variable Folder
n = ListadoArchivos.Count
'
ReDim a(1 To n, 1 To 2)
For Each archivo In ListadoArchivos
If InStr(1, archivo.Name, ".xml", vbTextCompare) Then
i = i + 1
a(i, 1) = archivo.Name
End If
If InStr(1, archivo.Name, ".pdf", vbTextCompare) Then
j = j + 1
a(j, 2) = archivo.Name
End If
Next archivo
sh.Range("A2").Resize(UBound(a, 1), 2).Value = a
End SubSi quieres todos en la misma columna, en las siguiente opción, nombre de archivo en la A y la fecha de creación en la B
Sub ListarArchivos_1()
Dim a As Variant
Dim Carpeta As String
Dim sh As Worksheet
Dim ListadoArchivos As Object, archivo As Object
Dim n As Long, i As Long, j As Long
'
Carpeta = "C:\trabajo\salida"
'
Set sh = Workbooks("Lector").Sheets("Hoja1")
Set ListadoArchivos = CreateObject("Scripting.FileSystemObject").GetFolder(Carpeta).Files ' Asigna la carpeta a la variable Folder
n = ListadoArchivos.Count
'
ReDim a(1 To n, 1 To 2)
For Each archivo In ListadoArchivos
If InStr(1, archivo.Name, ".xml", vbTextCompare) Then
i = i + 1
a(i, 1) = archivo.Name
End If
If InStr(1, archivo.Name, ".pdf", vbTextCompare) Then
j = j + 1
a(j, 2) = archivo.Name
End If
Next archivo
sh.Range("A2").Resize(UBound(a, 1), 2).Value = a
End SubSi quieres solamente los creados en febrero:
Sub ListarArchivos_3()
Dim a As Variant
Dim Carpeta As String
Dim sh As Worksheet
Dim ListadoArchivos As Object, archivo As Object
Dim n As Long, i As Long
'
Carpeta = "C:\trabajo\salida"
'
Set sh = Workbooks("Lector").Sheets("Hoja1")
Set ListadoArchivos = CreateObject("Scripting.FileSystemObject").GetFolder(Carpeta).Files ' Asigna la carpeta a la variable Folder
n = ListadoArchivos.Count
'
ReDim a(1 To n, 1 To 2)
For Each archivo In ListadoArchivos
If InStr(1, archivo.Name, ".xml", vbTextCompare) Or _
InStr(1, archivo.Name, ".pdf", vbTextCompare) Then
If Month(archivo.datecreated) = 2 Then 'filtra febrero
i = i + 1
a(i, 1) = archivo.Name
a(i, 2) = archivo.datecreated
End If
End If
Next archivo
sh.Range("A2").Resize(UBound(a, 1), 2).Value = a
End Sub[No olvides valorar.
. Si tienes dudas, comenta.
Me faltó la macro 2:
Sub ListarArchivos_2()
Dim a As Variant
Dim Carpeta As String
Dim sh As Worksheet
Dim ListadoArchivos As Object, archivo As Object
Dim n As Long, i As Long
'
Carpeta = "C:\trabajo\salida"
'
Set sh = Workbooks("Lector").Sheets("Hoja1")
Set ListadoArchivos = CreateObject("Scripting.FileSystemObject").GetFolder(Carpeta).Files ' Asigna la carpeta a la variable Folder
n = ListadoArchivos.Count
'
ReDim a(1 To n, 1 To 2)
For Each archivo In ListadoArchivos
If InStr(1, archivo.Name, ".xml", vbTextCompare) Or _
InStr(1, archivo.Name, ".pdf", vbTextCompare) Then
i = i + 1
a(i, 1) = archivo.Name
a(i, 2) = archivo.datecreated
End If
Next archivo
sh.Range("A2").Resize(UBound(a, 1), 2).Value = a
End Sub----
.
