Pintar de amarillo toda una fila en excel VBA

Tengo un libro de excel, con tres hojas (Hoja1, Hoja2 y Hoja3), en la Hoja1 tengo las columnas A (NUMERO), B (ORDEN), C (PAGADA), DE (NºFACTURA), E (FECHA), F (PROTOCOLO), G (N.I.F.), H (CLIENTE), I (IMPORTE), J (CÓDIGO), es decir 10 columnas; en la hoja2 y hoja3 la mismas cabeceras. En la hoja1 tengo todos los datos, con aproximadamente 10.000 líneas actualmente, pero aumentando. Yo quiero que poniendo una serie de datos, en la columna 4 de la hoja2, me lo busque en la hoja1, y lo encontrado me lo ponga en la hoja3.

Dante Amor muy amablemente me soluciono el problema, con la siguiente macro, que va muy bien, pero se me olvidó decirle que necesitaba, que cada vez que se encontraba una línea en la hoja1, esta línea se rellene con fondo amarillo la fila entera, con lo que me permite interpretar que esa factura ya ha sido contabilizada.

Adjunto el código de Dante Amor

Si el mismo Dante Amor u otro experto pudiera decirme, que código debería añadir para que se me rellenen las filas conforme se van encontrando, se lo agradecería mucho.

Esperando su respuesta

Un cordial saludo

Sub Buscar_3()
'Por Dante Amor
    Application.ScreenUpdating = False
    '
    Set h1 = Sheets("Hoja1")
    Set h2 = Sheets("Hoja2")
    Set h3 = Sheets("Hoja3")
    h3.Cells.ClearContents
    u3 = 2
    '
    For i = 2 To h2.Range("D" & Rows.Count).End(xlUp).Row
        Set b = h1.Columns("D").Find(h2.Cells(i, "D").Value, LookAt:=xlWhole)
        If Not b Is Nothing Then
            h1.Range("A" & b.Row & ":J" & b.Row).Copy
            h3.Range("A" & u3).PasteSpecial xlValues
            u3 = u3 + 1
        End If
    Next
    Application.ScreenUpdating = False
    MsgBox "Fin"
End Sub
1

1 Respuesta

195.000 pts. Los hombres aprenden mientras enseñan.

[Hola 

prueba la macro con los ajustes solicitada

Sub Buscar_3()
'Por Dante Amor
    Application.ScreenUpdating = False
    '
    Set h1 = Sheets("Hoja1")
    Set h2 = Sheets("Hoja2")
    Set h3 = Sheets("Hoja3")
    h3.Cells.ClearContents
    u3 = 2
    '
    For i = 2 To h2.Range("D" & Rows.Count).End(xlUp).Row
        Set b = h1.Columns("D").Find(h2.Cells(i, "D").Value, LookAt:=xlWhole)
        If Not b Is Nothing Then
            h1.Rows(b.Row).Interior.ColorIndex = 6
            h1.Range("A" & b.Row & ":J" & b.Row).Copy
            h3.Range("A" & u3).PasteSpecial xlValues
            u3 = u3 + 1
        End If
    Next
    Application.ScreenUpdating = False
    MsgBox "Fin"
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas