Macro que funciona pero es demasiado lenta

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.

Yo actualmente tengo una macro, que es la siguiente, pero es muy lenta, porque tiene que ir comparando en 10000 registros.

Sub Buscar()
Application.ScreenUpdating = False

Dim filah1, filah2, filah3 As Integer
Dim dato1, dato2 As Integer

filah1 = 2
filah2 = 2
filah3 = 2

'Borra el contenido de la Hoja3
Call Borrar

While Sheets("Hoja2").Cells(filah2, 4) <> Empty

While Sheets("Hoja1").Cells(filah1, 4) <> Empty
' dato1 = Sheets("Hoja2").Cells(filah2, 4)
' dato2 = Sheets("Hoja1").Cells(filah1, 4)
If Sheets("Hoja2").Cells(filah2, 4) = Sheets("Hoja1").Cells(filah1, 4) Then
Sheets("Hoja1").Select
Sheets("Hoja1").Cells(filah1, 4).Select
ActiveCell.Rows("1:1").EntireRow.Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With

Sheets("Hoja3").Cells(filah3, 1) = Sheets("Hoja1"). Cells(filah1, 1)
Sheets("Hoja3").Cells(filah3, 2) = Sheets("Hoja1"). Cells(filah1, 2)
Sheets("Hoja3").Cells(filah3, 3) = Sheets("Hoja1"). Cells(filah1, 3)
Sheets("Hoja3").Cells(filah3, 4) = Sheets("Hoja1"). Cells(filah1, 4)
Sheets("Hoja3").Cells(filah3, 5) = Sheets("Hoja1"). Cells(filah1, 5)
Sheets("Hoja3").Cells(filah3, 6) = Sheets("Hoja1"). Cells(filah1, 6)
Sheets("Hoja3").Cells(filah3, 7) = Sheets("Hoja1"). Cells(filah1, 7)
Sheets("Hoja3").Cells(filah3, 8) = Sheets("Hoja1"). Cells(filah1, 8)
Sheets("Hoja3").Cells(filah3, 9) = Sheets("Hoja1"). Cells(filah1, 9)
Sheets("Hoja3").Cells(filah3, 10) = Sheets("Hoja1"). Cells(filah1, 10)
filah3 = filah3 + 1
End If
filah1 = filah1 + 1
Wend

filah2 = filah2 + 1
filah1 = 2

Wend

Application.ScreenUpdating = True
End Sub

Mi pregunta es si habría la posibilidad, de hacerlo con otras instrucciones que hicieran el proceso de búsqueda más rápido.

2

2 Respuestas

4.709.275 pts. Sancho, si los perros ladran ...

Prueba con el siguiente código

Sub Buscar_2()
'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 r = h1.Columns("D")
        Set b = r.Find(h2.Cells(i, "D").Value, LookAt:=xlWhole)
        If Not b Is Nothing Then
            celda = b.Address
            Do
                h1.Range("A" & b.Row & ":J" & b.Row).Copy
                h3.Range("A" & u3).PasteSpecial xlValues
                u3 = u3 + 1
                Set b = r.FindNext(b)
            Loop While Not b Is Nothing And b.Address <> celda
        End If
    Next
    Application.ScreenUpdating = False
    MsgBox "Fin"
End Sub

Avísame si se redujo el tiempo.

'.[Sal u dos. Dante Amor. No olvides valorar la respuesta. 
'.[Avísame cualquier duda

¡Gracias!

Bueno, se ha reducido tanto que si antes tardaba 5 minutos ahora ha tardado 30segundos

Muchísimas gracias

Si no existe el caso de que en la hoja1 haya más de una factura, entonces prueba con el siguiente:

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

Al final de mi respuesta hay un botón para valorar: Voto y Excelente, apreciaría que cambiaras la valoración.

Sal u dos

Bueno ahora me has descolocado con el sub buscar3, que me has tildado todo el bucle For.

En la hoja1 tengo 10.000 facturas, pero ninguna tiene un NºFactura repetido, y en la Hoja2, que es donde pongo las facturas a buscar, lógicamente, tampoco repito el NºFACTURA, por lo que el primer código que me has enviado, ha funcionado estupendamente. Por eso el segundo que lo veo tildado en verde, no entiendo porque es.

Se pone de color verde por un efecto de esta página. Pero lo que hice fue quitar un ciclo Do- Loop, ya que como mencionaste que solamente existe una factura, no tiene caso que realice más de una búsqueda. Entonces la búsqueda de la macro 3, debe ser más rápida :)

210.675 pts. Si de mis mayores gustos, mis disgustos han nacido,...

Prueba esta macro, busca las facturas que hay en la hoja 2, cuenta cuantas hay de cada una en la hoja 1 y en un solo paso las copia todas a la hoja 3, eso reduce bastante el tiempo de funcionamiento.

Sub copiar_facturas()
Dim x As WorksheetFunction
Set h1 = Worksheets("hoja1")
Set h2 = Worksheets("hoja2")
Set H3 = Worksheets("hoja3")
Set x = WorksheetFunction
Set DATOS = h1.Range("a1").CurrentRegion
Set FACTURAS = h2.Range("a1").CurrentRegion
Set DESTINO = H3.Range("A1").CurrentRegion
With DESTINO
    R3 = .Rows.Count
    If R3 > 0 Then
        .Rows(2).Resize(R3).ClearContents
    End If
End With
With DATOS
    .Sort key1:=h1.Range(.Columns(4).Address), order1:=xlAscending, Header:=xlYes
End With
With FACTURAS
    r = .Rows.Count
    For i = 2 To r
        Fact = .Cells(i, 4)
        cuenta = x.CountIf(DATOS.Columns(4), Fact)
        If cuenta > 0 Then
            fila = x.Match(Fact, DATOS.Columns(4), 0)
            Set FACTURA = DATOS.Rows(fila).Resize(cuenta)
            Set DESTINO = H3.Range("A1").CurrentRegion
            Set DESTINO = DESTINO.Rows(DESTINO.Rows.Count + 1).Resize(cuenta)
            DESTINO.Value = FACTURA.Value
        End If
    Next i
End With
Set DATOS = Nothing: Set FACTURA = Nothing: Set DESTINO = Nothing
End Sub

¡Gracias!

También va bien, pero como no se da el caso de que en la hoja1 pueda haber una misma factura repetida, el código, que me ha enviado Dante Amor, es más reducido. Este también funciona muy rápido, por lo que le agradezco como a Dante Amor su contestación.

Muchas, muchas gracias

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas