Comme ceci ...
La recherche de 1.000 valeurs parmi 10.000 prend moins d'une seconde.
Option Explicit
Dim data
Sub RECH()
Dim plage1 As Range, cel As Range, x As Double, liste, i As Double
Dim resultat()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ActiveSheet
data = .Range("A1").CurrentRegion
liste = .Range("I2:I" & .Range("I" & Rows.Count).End(xlUp).Row)
ReDim resultat(1 To UBound(liste), 1 To 1)
For i = 1 To UBound(liste)
x = dichotomie(liste(i, 1))
If x = 0 Then
liste(i, 1) = 0
Else
liste(i, 1) = data(x, 3)
End If
Next
.Range("J2").Resize(UBound(liste), 1) = liste
End With
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
Function dichotomie(valeurcherchee As Variant) As Double
' donne la ligne de la valeur recherchée (0 si pas trouvé)
Dim deb As Double, fin As Double, milieu As Double
Dim valeurcourante As Variant
dichotomie = 0
deb = 2: fin = UBound(data)
If valeurcherchee = data(deb, 1) Then dichotomie = deb: Exit Function
If valeurcherchee = data(fin, 1) Then dichotomie = fin: Exit Function
While deb <> fin - 1
milieu = Int((deb + fin) / 2)
valeurcourante = data(milieu, 1)
If valeurcourante = valeurcherchee Then
dichotomie = milieu
Exit Function
Else
If valeurcourante > valeurcherchee Then
fin = milieu
Else
deb = milieu
End If
End If
Wend
End Function