[VBA] Index Equiv multicritère

[Spinzi]

Bonjour à tous,

je dois travailler sur une base de données plutôt grosse (200 000 lignes) et ramener des informations grâce à une formule matricielle.
la formule fonctionne mais sur 200 000 lignes, ça rame bcp et il me faut plusieurs heures pour mettre à jour les informations.

Aussi, malgré ma faible expérience en VBA, j'ai décidé de remplacer la formule matricielle par une formule intégrée et calculé dans un module grâce aux array.

Cependant, la formule ne me renvoie que des "#N/A" et je ne sais pas d'où vient le souci.

Je cherche à récupérer la date comptable (colonne H) pour les types de pièces "DZ" parmi les pièces de type "RV" (colonne I) et du numéro de pièce de rapprochement (colonne S) qui sont concaténé (colonne U) pour plus de simplicité dans le code VBA.
La formule à matérialiser au format VBA est la suivante :

=SI(ET(I3="RZ";S3<>"");INDEX($H$3:$H$196233;EQUIV("RZ"&S3;$I$3:$I$196233&$S$3:$S$196233;));"#N/A")

Je souhaiterais un code dynamique (qui s'adapte au nombre de lignes d'où le "DerLigne") et rapide (d'où l'utilisation d'array - que je ne maitrise pas, code trouvé sur la toile et "adapté" à mon besoin ).
Vous trouverez le code en question ci dessous et le fichier en PJ (fichier originel contient 196 233 lignes) :

Option Explicit
Sub Rapprochement()
Dim i As Long
Dim DerLigne As Long
Dim ARRAY_PLAGE_RESULTAT As Variant
Dim OBJET_PLAGE_RECHERCHE As Object

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = 0
DerLigne = Range("A" & Rows.Count).End(xlUp).Row

'[PLAGE_RESULTAT].Range(Cells(3, 22), Cells(DerLigne, 22)).ClearContents 'reset de la zone de r?sultat
ARRAY_PLAGE_RESULTAT = Range("A2:V" & DerLigne).Value
Set OBJET_PLAGE_RECHERCHE = Range("A2:U" & DerLigne)

For i = 3 To 3000 'UBound(ARRAY_PLAGE_RESULTAT, 1) remplacé par 3000 car trop long sinon
If ARRAY_PLAGE_RESULTAT(i, 9) = "DZ" Then
ARRAY_PLAGE_RESULTAT(i, 22) = Application.index(OBJET_PLAGE_RECHERCHE, Application.match(ARRAY_PLAGE_RESULTAT(i, 19) & "&" & "RV", OBJET_PLAGE_RECHERCHE.Columns(20), 0), 1)
End If
Next i

Range("A2:V" & DerLigne).Formula = ARRAY_PLAGE_RESULTAT

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = 1
End Sub

Merci d'avance de votre contribution,
Spinzi

 

[Bebere]

bonjour
pour gagner du temps éviter les aller/retour feuille
à tester

Sub Rapprochement()

Dim i As Long
Dim DerLigne As Long
Dim ARRAY_PLAGE_RESULTAT As Variant
Dim OBJET_PLAGE_RECHERCHE() ' As Object
Dim debut As Date


Application.Calculation = xlCalculationManual
Application.ScreenUpdating = 0

DerLigne = Range("A" & Rows.Count).End(xlUp).Row

ReDim OBJET_PLAGE_RECHERCHE(1 To DerLigne, 1 To 1)
'[PLAGE_RESULTAT].Range(Cells(3, 22), Cells(DerLigne, 22)).ClearContents 'reset de la zone de résultat
ARRAY_PLAGE_RESULTAT = Range("A2:V" & DerLigne).Value '= zone verte
'Set OBJET_PLAGE_RECHERCHE = Range("A2:U" & DerLigne) '= zone orange

debut = Now
For i = 3 To UBound(ARRAY_PLAGE_RESULTAT, 1)
    If ARRAY_PLAGE_RESULTAT(i, 9) = "DZ" Then
   '     ARRAY_PLAGE_RESULTAT(i, 22) = Application.index(OBJET_PLAGE_RECHERCHE, Application.match(ARRAY_PLAGE_RESULTAT(i, 19) & "&" & "RV", OBJET_PLAGE_RECHERCHE.Columns(20), 0), 1)
 OBJET_PLAGE_RECHERCHE(i, 1) = ARRAY_PLAGE_RESULTAT(i, 8)
    End If
Next i
Range("V3").Resize(UBound(OBJET_PLAGE_RECHERCHE, 1), UBound(OBJET_PLAGE_RECHERCHE, 2)) = OBJET_PLAGE_RECHERCHE
'Range("A2:V" & DerLigne).Formula = ARRAY_PLAGE_RESULTAT
MsgBox Format(Now - debut, "hh:mm:ss")

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = 1

End Sub

 

[job75]

Bonjour Spinzi, Bebere,

Ce n'est pas du tout comme ça qu'il faut utiliser les tableaux VBA si l'on veut aller vite.

Et ceci n'a pas de sens puisque les "DZ" et "RV" sont dans la même colonne :

Je cherche à récupérer la date comptable (colonne H) pour les types de pièces "DZ" parmi les pièces de type "RV" (colonne I)

C'est soit l'un, soit l'autre, soit toutes les lignes, voici pour toutes les lignes :

Sub Rapprochement()
Dim tablo, d As Object, i&, x$, resu()
With [A2].CurrentRegion.Resize(, 20) 'A à T
    '---liste des éléments concaténés---
    tablo = .Value
    Set d = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(tablo)
        x = tablo(i, 9) & tablo(i, 19)
        If x <> "" And Not d.exists(x) Then d(x) = i 'mémorise le numéro de la 1ère ligne trouvée
    Next
    '---tableau des résultats---
    ReDim resu(1 To UBound(tablo), 1 To 1)
    For i = 2 To UBound(tablo)
        x = tablo(i, 9) & tablo(i, 19)
        If x <> "" Then resu(i, 1) = tablo(d(x), 8) 'valeur en colonne H
    Next
    '---restitution en colonne T (20)---
    resu(1, 1) = tablo(1, 20)
    .Columns(20) = resu
End With
End Sub

Testez le fichier joint, sur les 17 888 lignes la macro s'exécute chez moi en 0,15 seconde.

Bonne journée.

 

[Spinzi]

Bonjour Bebere, Job75

@Bebere : merci bcp pour ce code qui tourne sans problème sur mes 200 000 lignes (- de 2 secondes).
Par contre, les résultats sont décalés d'une ligne. J'ai tenté de modifier le code mais sans succès :

Range("V2").Resize(UBound(OBJET_PLAGE_RECHERCHE, 1), UBound(OBJET_PLAGE_RECHERCHE, 2)) = OBJET_PLAGE_RECHERCHE

car le code m'écrase la cellule V2

@job75 : oui je sais que je ne sais pas utiliser les tableaux =)
Mon souhait est de ramener la date comptable pour les pièces de type "DZ" en fonction du type de pièce RV et d'un numéro de rapprochement. Mon explication n'est pas assez précise ou le fait d'utiliser des tableaux ne permet pas de repondre à mon besoin ?

Merci à vous pour vos retours,
Spinzi

 

[Bebere]

bonjour

Sub Rapprochement()

Dim i As Long
Dim DerLigne As Long
Dim ARRAY_PLAGE_RESULTAT As Variant
Dim debut As Date, x As String
Dim Rng As Range

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = 0
debut = Now

DerLigne = Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Range("V3:V" & DerLigne)
Rng.ClearContents
ARRAY_PLAGE_RESULTAT = Range("A3:V" & DerLigne).Value '= zone verte

For i = 1 To UBound(ARRAY_PLAGE_RESULTAT, 1)
    If ARRAY_PLAGE_RESULTAT(i, 9) = "DZ" Then
    
  If Left(ARRAY_PLAGE_RESULTAT(i, 20), 2) = "DZ" Then
 Rng.Cells(i, 1) = ARRAY_PLAGE_RESULTAT(i, 8)
    End If
    End If
Next i
MsgBox Format(Now - debut, "hh:mm:ss")

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = 1

End Sub

le code de Job est plus rapide
edit mis un nouveau code

 

[Spinzi]

Re,

@Bebere : merci pour le code, seulement je n'ai pas compris l'argument que vous avez rajouté, pouvez vous m'expliquer ?

@job75 : Je teste votre solution et (surtout) essaye de comprendre pourquoi je n'ai pas la logique ^^

Merci à vous,
Spinzi

 

[job75]

Maintenant si l'on veut limiter les résultats au type "DZ" il suffit de modifier légèrement la macro du post #3 :

Sub Rapprochement()
Dim tablo, d As Object, i&, x$, resu()
With [A2].CurrentRegion.Resize(, 20) 'A à T
    '---liste des éléments concaténés avec DZ---
    tablo = .Value
    Set d = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(tablo)
        If tablo(i, 9) = "DZ" Then
            x = tablo(i, 9) & tablo(i, 19)
            If Not d.exists(x) Then d(x) = i 'mémorise le numéro de la 1ère ligne trouvée
        End If
    Next
    '---tableau des résultats---
    ReDim resu(1 To UBound(tablo), 1 To 1)
    For i = 2 To UBound(tablo)
        If tablo(i, 9) = "DZ" Then resu(i, 1) = tablo(d(tablo(i, 9) & tablo(i, 19)), 8) 'valeur en colonne H
    Next
    '---restitution en colonne T (20)---
    resu(1, 1) = tablo(1, 20)
    .Columns(20) = resu
End With
End Sub

Fichier (2).

Nota : au post #3 j'avais écrit With [A1]… je corrige.

 

[Bebere]

Spinzi les 2 lignes if dans la boucle i

 

[Spinzi]

Bonjour à tous,

encore merci pour vos solutions qui, même si elles ne sont pas encore parfaites (=3) sont super rapides !

En PJ le dernier fichier à date avec, tout à la fin, une erreur dans la recherche multicritère avec ce que j'espère en résultat (dernière ligne, colonne X).

Merci d'avance pour votre expertise et vos pistes d'amélioration.
Spinzi

 

[Spinzi]

Bonjour à tous,

personne pour résoudre mon problème ?

Spinzi

 

[job75]

Bonjour Spinzi, Bebere,

Alors ne pas concaténer tablo(i, 9), modifiez la macro comme suit :

Sub Rapprochement2()
Dim tablo, d As Object, i&, x$, resu()
With [a2].CurrentRegion.Resize(, 23) 'A à W
    '---liste des éléments concaténés avec DZ---
    tablo = .Value
    Set d = CreateObject("Scripting.Dictionary")
    For i = 3 To UBound(tablo)
        x = tablo(i, 19)
        If x <> "" And Not d.exists(x) Then d(x) = i 'mémorise le numéro de la 1ère ligne trouvée
    Next
    '---tableau des résultats---
    ReDim resu(1 To UBound(tablo), 1 To 1)
    For i = 3 To UBound(tablo)
        x = tablo(i, 19)
        If tablo(i, 9) = "DZ" And d.exists(x) Then resu(i, 1) = tablo(d(x), 8) 'valeur en colonne H
    Next
    '---restitution en colonne W (23)---
    resu(1, 1) = tablo(1, 23)
    .Columns(23) = resu
End With
End Sub

A+

 

[Spinzi]

Bonjour Job75,

ça fonctionne niquel, merci !
J'ai encore bcp de mal à comprendre l'utilisation des arrays mais qu'est ce que c'est agréable quand ca va vite =)
Ce que je comprends c'est qu'avec le format "tableau" il est difficile de rajouter des conditions. Donc si j'ai bien compris, si je veux avoir les bons résultats (avoir la date des pièce de rapprochement des pièces de type "RV" sur les ligne de type de pièce "DZ") il faut que je filtre au préalable pour n'avoir que ces 2 données.

Je clôture le sujet.
Encore merci,
Spinzi

 

[Spinzi]

Bonjour à tous,

je reviens car qqchose me trotte dans la tête : en fait ce n'est pas une recherche multicritere en array. Est-ce que ça existe ? Est-ce que c'est possible ?

 

[job75]

Bonjour Spinzi, le forum,

Recherche multicritère ? Dans la macro précédente vous pouvez toujours remplacer :

If x <> "" And Not d.exists(x) Then d(x) = i 'mémorise le numéro de la 1ère ligne trouvée

par :

If x <> "" And (tablo(i, 9) = "DZ" Or tablo(i, 9) = "RV") And Not d.exists(x) Then d(x) = i 'mémorise le numéro de la 1ère ligne trouvée

Bonne journée.