Macro que funciona pero es demasiado lenta

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.

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