Extraction des donnees

Bonjour chers tous

Je voudrais rechercher et extraire des informations sur une plage à partir d'une autre plage par vba.

On peut le faire avec la fonction RechercheV comme illustré dans mon fichier test mais avec une plage énorme ( plus de mille lignes ) cela prend plusieurs minutes.

Existe t'il un autre procédé plus efficace pour le faire ? Merci

Bonjour,

une RECHERCHEV avec paramètre FAUX (ou 0) est en effet longue car elle est séquentielle

il faudrait d'abord trier la table de référence, et ensuite faire une recherche dichotomique

Voici une fonction que tu peux utiliser ...

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

Merci cher Steelson

Mais comment l'utiliser dans mon cas précis ?

ok, voici

edit : fichier corrigé

version un peu plus rapide (les données sont stockés dans un array)

edit : fichier corrigé

Excellent!!

Mais essayez de revoir un petit quelque chose doit manquer . Ca donne pas correctement tous les résultats.

Et en complément je souhaiterais mettre 0 si le code non présent dans la plage source au lieu de vide

Merci!!

Remplace

            If x <> 0 Then cel.Offset(0, 1) = data(x, 3)

par

            cel.Offset(0, 1) = iif(x=0,0,data(x, 3))

pas testé, fait à main levée

Steelson a écrit :

il faudrait d'abord trier la table de référence

edit : fichier corrigé

OK mais ma préoccupation demeure

Peux tu jeter un coup d'œil

sur le fichier ?

Exact, j'avais en effet déjà rencontré cela et oublié de l'ajouter dans mes archives.

Il faut que j'ajoute un test aux bornes.

Merci pour la remarque, je corrige.

Correction

Option Explicit
Dim data

Sub RECH()
Dim plage1 As Range, cel As Range, x As Double

With ActiveSheet

    data = .Range("A1").CurrentRegion
    Set plage1 = .Range("I2:I" & .Range("I" & Rows.Count).End(xlUp).Row)

        For Each cel In plage1
            x = dichotomie(cel.Value)
            If x = 0 Then
            cel.Offset(0, 1) = 0
            Else
            cel.Offset(0, 1) = data(x, 3)
           End If
        Next cel

End With
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

MERCI

C'est corrigé.

Je l'adapte a un autre fichier pour voir si j'ai bien compris et puis-je vous revenir si je coince ?

je peux ajouter le tri dans la macro si besoin

J'ai pu le faire Merci .

Mais pour des bases de données énormes comment peut on l'accélérer ?

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

MERCI Mon Cher!

Parfait !

N'oublie pas de clore le fil de discussion en cliquant sur