Macro para filtrar y pegar datos tipo texto en una hoja nueva del mismo libro.
Tengo un libro de Excel y este contiene una hoja con los siguientes encabezados:
1. No.
2. Categoría
3. Cuerpo
4. Género.
5. Promoción
6. Grado
7. Especialidad
8. Apellidos
9. Nombres
10. Cédula
11. RH.
12. Notas
13. Area
Necesito una macro que me filtre a partir de la celda "C4" en una hoja llamada "Listado", todos aquellos empleados que sean del área que se escriba en "C2", estos datos filtrados y pegados, deben ser pegados in ningún tipo de formato especial y que de todas las columnas, solo me peque la siguiente información:
1. No.
2. Grado
3. Género.
7. Apellidos
8. Nombres
9. Cédula
10. RH.
12. Notas
He estado intentando usar esa macro, pero no me ha funcionado como la necesito:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C2")) Is Nothing Then
Application.ScreenUpdating = False
Sheets("Lista").Range("A4").CurrentRegion.ClearContents
On Error Resume Next
With Sheets("Funcionarios")
.Range("A2").AutoFilter field:=13, Criteria1:=Sheets("Lista").Range("C2")
.Range("A2").CurrentRegion.Copy Sheets("Lista").Range("A4")
.AutoFilterMode = Falseç
End With
With Sheets("Lista")
LR = Range("B" & Rows.Count).End(xlUp).Row
.Range("A5").Value = 1
.Range("A5").AutoFill Destination:=Range("A5:A" & LR), Type:=xlFillSeries
End With
Application.ScreenUpdating = True
End If
End Sub
1 respuesta
Te anexo la macro, suponiendo que los encabezados de la hoja "funcionarios" están en la fila 2 y que la hoja "lista" los encabezados están en la fila 4.
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("C2")) Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Set h1 = Sheets("Funcionarios")
Set h2 = Sheets("Lista")
'
h2.Rows("4:" & Rows.Count).ClearContents
u1 = h1.Range("M" & Rows.Count).End(xlUp).Row
h1.Range("A2:M" & u1).AutoFilter Field:=13, Criteria1:=Target.Value
cols = Array(1, 6, 4, 8, 9, 11, 12)
c = 1
u1 = h1.Range("M" & Rows.Count).End(xlUp).Row
If u1 > 2 Then
For j = LBound(cols) To UBound(cols)
h1.Range(h1.Cells(2, cols(j)), h1.Cells(u1, cols(j))).Copy h2.Cells(4, c)
c = c + 1
Next
Else
MsgBox "No existen datos"
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Feliz Año 2018
.
¡Gracias! , es espectacular lo que has hecho con esta macro, muchas gracias..!
Como seria posible evitar que al copiar los datos filtrados a la otra hoja, no me peque también las rayas de las tablas dinámicas y también, que una vez se realice el fitrol y posterio copiado a la otra hoja, inmediatamente se desactive el filtro en la "Funcionarios", para que no me quede filtrado.
Con esto, queda más que perfecta mi macro. Muchas gracias por tu valiosa colaboración
Te anexo la macro actualizada
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("C2")) Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Set h1 = Sheets("Funcionarios")
Set h2 = Sheets("Lista")
'
h2.Rows("4:" & Rows.Count).ClearContents
u1 = h1.Range("M" & Rows.Count).End(xlUp).Row
h1.Range("A2:M" & u1).AutoFilter Field:=13, Criteria1:=Target.Value
cols = Array(1, 6, 4, 8, 9, 11, 12)
c = 1
u1 = h1.Range("M" & Rows.Count).End(xlUp).Row
If u1 > 2 Then
For j = LBound(cols) To UBound(cols)
h1.Range(h1.Cells(2, cols(j)), h1.Cells(u1, cols(j))).Copy
h2.Cells(4, c).PasteSpecial xlValues
c = c + 1
Next
Else
MsgBox "No existen datos"
End If
If h1.AutoFilterMode Then h1.AutoFilterMode = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta.
¡Gracias! , voy revisarla ya mismo..!
La macro funciona de maravilla, ya me copia los datos en la otra hoja, sin las rayas de la tabla dinámica.
Sin embargo, no he logrado que después de el filtrado y copia a la hoja nueva, me vuelva a dejar la hoja funcionarios desfiltrada.
Pero de todas formas, ya me hace lo que necesitaba, muchas gracias Dante, un feliz año 2018 para ti.
Esta línea en la macro es para quitar el filtro
If h1.AutoFilterMode Then h1.AutoFilterMode = False
Revisa que la hayas puesto en la macro
Si señor, pero, por alguna razón, no me está funcionando en mi archivo. La tengo tal cual me la enviaste, pero me desfiltra la hija Funcionarios.
Ya no entendí, en dónde quieres quitar el filtro, en funcionarios o en "lista"
Si también lo quieres en "lista" agrega también esta línea:
If h2.AutoFilterMode Then h2.AutoFilterMode = False
en mis pruebas, después de filtrar, copiar y pegar, quita el filtro de "funcionarios". O tal vez tienes un filtro avanzado? o es un filtro de tabla dinámica?
La primera hoja, donde se filtran los datos y posteriormente se pegan en la hoja "Lista", se llama "Funcionarios", una vez se ha realizado el filtro y pegado la información filtrada en la hoja "Lista", entonces en la hoja "Funcionarios", se debe desactivar automáticamente el filtro aplicado.
Pero en mi fichero, no funciona, desconozco el motivo.
Prueba con esta:
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("C2")) Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Set h1 = Sheets("Funcionarios")
Set h2 = Sheets("Lista")
'
h2.Rows("4:" & Rows.Count).ClearContents
u1 = h1.Range("M" & Rows.Count).End(xlUp).Row
h1.Range("A2:M" & u1).AutoFilter Field:=13, Criteria1:=Target.Value
cols = Array(1, 6, 4, 8, 9, 11, 12)
c = 1
u1 = h1.Range("M" & Rows.Count).End(xlUp).Row
If u1 > 2 Then
For j = LBound(cols) To UBound(cols)
h1.Range(h1.Cells(2, cols(j)), h1.Cells(u1, cols(j))).Copy
h2.Cells(4, c).PasteSpecial xlValues
c = c + 1
Next
Else
MsgBox "No existen datos"
End If
On Error Resume Next
h1.ShowAllData
If h1.AutoFilterMode Then h1.AutoFilterMode = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
