Filtrar por color y poner en otra hoja

Buenos días, necesito realizar un filtro por color pero ese listado lo tengo en la hoja 1, lo que quiero hacer es que los que tengan el color se me vayan para la hoja2 a un rango de celdas que yo quiera.. A11 hasta A30 que solo pasen los que tengan color..

Respuesta
1

Prueba con esta macro, copiara solo las filas coloreadas en amarillo a la hoja 2

Sub copiar_coloreados()
Set datos = Range("a1").CurrentRegion
With datos
    filas = .Rows.Count
    x = 1
    For i = 1 To filas
        xcolor = .Cells(i, 1).Interior.ColorIndex
        If xcolor > 0 Then
            .Rows(i).Copy
            Sheets("hoja2").Range("a2").Rows(x).PasteSpecial
            x = x + 1
        End If
    Next i
End With
Set datos = Nothing
End Sub

Gracias , es mas o menos lo que necesito pero con esa macro me pasa todo los datos a la nueva lista, hay alguna forma de hacerlo automático apenas vaya marcando los colores. que solo pasen las que yo marque con el color, y que si le quito el color desaparezca del listado. gracias

No hay eventos en excel que activen macros en cuanto cambies el color aunque si existen eventos como change y selectionchange que se activen en cuando cambies el contenido de la celda, lo mas parecido es selectionchange basta con que cambies de una celda en blanco a una celda coloreada para activar la macro

Pero al menos que solo me pase los datos que celdas con los datos de color seleccionado, es que me los esta pasando todos.

Entonces si entendí bien corrígeme si me equivoco, ¿solo quieres el contenido de la columna A que este coloreada?, si es así es la misma macro, así que ahora en vez de copiar los datos de fila toda la fila coloreada solo copia las celdas de coloreadas de la columna A

Sub copiar_coloreados()
Set datos = Range("a1").CurrentRegion
With datos
    filas = .Rows.Count
    x = 1
    For i = 1 To filas
        xcolor = .Cells(i, 1).Interior.ColorIndex
        If xcolor > 0 Then
            .cells(i,1).Copy
            Sheets("hoja2").Range("a2").Rows(x).PasteSpecial
            x = x + 1
        End If
    Next i
End With
Set datos = Nothing
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas