MACRO Filtrar datos y copiarlos en otra hoja Visual Basic Excel
Os paso un código que hice para filtrar datos en una hoja y luego pegarlos en otra en función del filtro. Hay veces que al filtrar no hay datos, así que me pega el encabezado en la hoja correspondiente. Llevo con esto ya unas semanas y no soy capaz de añadir ahí una excepción. Intenté con:
If Activesheet.filtermode = True Then
... PEGA LOS DATOS EN LA HOJA CORRESPONDIENTE
Else
Msgbox "No hay datos en el filtro, pulsa OK para continuar"
Pero me dice que no acepta esta propiedad o método. El excel tiene 3 hojas: ORIGEN, PRODUCTO Y SERVICIO. En origen filtra por PRODUCTO y lo pega en la hoja producto, y luego filtra por SERVICIO y lo pega en la hoja SERVICIO. Pero hay veces que no existen uno de los dos y se pega en la hoja el encabezado de la hoja ORIGEN. No consigo adecuar el código a las soluciones que me han ido dando por ahí o directamente no funciona.
Este es el código:
Sub filtrar()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
'Quitamos filtro si lo hay
If Worksheets("ORIGEN").FilterMode Then Worksheets("ORIGEN").ShowAllData
'Filtramos datos SERVICIO
Worksheets("ORIGEN").Range("F1").AutoFilter Field:=6, Criteria1:="SERVICIO"
Dim UltimaFila As Long
'Para pegar los datos de la columna G en hoja SERVICIO
Sheets("ORIGEN").Activate
Let UltimaFila = Worksheets("ORIGEN").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("ORIGEN").Range("G2:G" & UltimaFila).Copy Destination:=Worksheets("SERVICIO").Cells(7, 3)
'Quitamos filtro si lo hay
If Worksheets("ORIGEN").FilterMode Then Worksheets("ORIGEN").ShowAllData
'Filtramos datos PRODUCTO
Worksheets("ORIGEN").Range("F1").AutoFilter Field:=6, Criteria1:="PRODUCTO"
'Para pegar los datos de la columna G de hoja origen en hoja PRODUCTO
Sheets("ORIGEN").Activate
Let UltimaFila = Worksheets("ORIGEN").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("ORIGEN").Range("G2:G" & UltimaFila).Copy Destination:=Worksheets("PRODUCTO").Cells(7, 3)
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
End Sub
1 respuesta
Lo siguiente me funciona muy bien, pruébalo y me comentas.
Sub filtrar()
Dim uf1 As Long, uf2 As Long, sh As Worksheet
'
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
'
Set sh = Sheets("ORIGEN")
sh.DisplayPageBreaks = False
If sh.FilterMode Then sh.ShowAllData 'Quitamos filtro si lo hay
'
uf1 = sh.Cells(Rows.Count, "F").End(xlUp).Row 'Utiliza la misma columna donde haces el filtro
sh.Range("A1:G" & uf1).AutoFilter 6, "SERVICIO" 'Filtramos datos SERVICIO
uf2 = sh.Cells(Rows.Count, "F").End(xlUp).Row 'revisamos si existen datos
If uf2 = 1 Then
MsgBox "No hay datos 'Servicio'", vbExclamation
Else
sh.Range("G2:G" & uf2).Copy Sheets("SERVICIO").Cells(7, 3)
End If
'
sh.Range("F1:F" & uf1).AutoFilter 6, "PRODUCTO" 'Filtramos datos PRODUCTO
uf2 = sh.Cells(Rows.Count, "F").End(xlUp).Row 'revisamos si existen datos
If uf2 = 1 Then
MsgBox "No hay datos 'Producto'", vbExclamation
Else
sh.Range("G2:G" & uf2).Copy Sheets("PRODUCTO").Cells(7, 3)
End If
sh.ShowAllData
sh.DisplayPageBreaks = True
'
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.CutCopyMode = False
End With
End Sub
Funciona perfecto, Dante! Jo, mil gracias. Llevaba con esto varias semanas!
Me alegra saber que funciona para ti, gra cias por comentar.
