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

Respuesta
2

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.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas