Macro que recorre carpeta y filtra
Tengo lo siguiente en una carpeta alrededor de 300 archivos todos con la misma información y diferente nombre, tengo que hacer una macro que recorra los archivos y filtre la columna E con los que digan APLAZADOS y otro filtro en la columna G con los que digan POR EVALUAR, en cada archivo los que queden en ese filtro copiarlos en el archivo abierto y asi para los 300 archivos. Osea la final me queda un solo archivo con los filtros de todos.
1 Respuesta
Si tiene encabezado, ¿cuál es el encabezado de la columna E y cuál de la G?
Hola gracias por tu pronta respuesta.
Si tienen encabezados, y estan en la fila 13, los registros inician en la fila 14. En todos los archivos la hoja se llama "Hoja" y solo hay una en cada archivo. La carpeta se llama fichas.
El encabezado para la columna E es "Estado" y aquí se debe filtrar los registros que aparezcan "EN FORMACION" o "CONDICIONADOS", y para la columna H, que pena no era la g EL ENCABEZADO es "Juicio de Evaluación" y se deben filtrar los que aparezcan "por evaluar".
Una vez aplicado el filtro que copie todos los datos a la hoja abierta.
Gracias DAM
Te anexo la macro, en el libro donde vas a ejecutar la macro deberás tener 2 hojas "Hoja1" para poner la información y la hoja "datos".
En la hoja "datos", pon la información, tal y como se muestra en la siguiente imagen:
Sub Filtrar()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Hoja1")
h1.Cells.Clear
Set h3 = l1.Sheets("datos")
ruta = l1.Path & "\"
ChDir ruta
'
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Selecciona una carpeta"
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show <> -1 Then Exit Sub
cp = .SelectedItems(1)
End With
'
ChDir cp & "\"
archi = Dir("*.xls*")
Do While archi <> ""
Set l2 = Workbooks.Open(archi)
Set h2 = l2.ActiveSheet
h2.Range("A13:H" & h2.Range("E" & Rows.Count).End(xlUp).Row).AdvancedFilter _
Action:=xlFilterInPlace, _
CriteriaRange:=h3.Range("A1:B3"), Unique:=False
u = h2.Range("E" & Rows.Count).End(xlUp).Row
If u > 13 Then
u1 = h1.Range("E" & Rows.Count).End(xlUp).Row + 1
h2.Rows(14 & ":" & u).Copy h1.Range("A" & u1)
End If
l2.Close False
archi = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Terminado"
End SubSaludos.Dante Amor
