[VBA] Index Equiv multicritère

Spinzi

XLDnaute Impliqué
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 :
Code:
=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) :
Code:
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
 

Pièces jointes

  • Test Index Equiv Array vSpinzi.xlsb
    349.8 KB · Affichages: 20
Dernière édition:

Bebere

XLDnaute Barbatruc
bonjour
pour gagner du temps éviter les aller/retour feuille
à tester
VB:
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

XLDnaute Barbatruc
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 :
VB:
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.
 

Pièces jointes

  • Test Index Equiv Array vSpinzi(1).xlsb
    264.4 KB · Affichages: 21
Dernière édition:

Spinzi

XLDnaute Impliqué
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 :
Code:
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

XLDnaute Barbatruc
bonjour

VB:
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
 
Dernière édition:

job75

XLDnaute Barbatruc
Maintenant si l'on veut limiter les résultats au type "DZ" il suffit de modifier légèrement la macro du post #3 :
VB:
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.
 

Pièces jointes

  • Test Index Equiv Array vSpinzi(2).xlsb
    264.5 KB · Affichages: 10

Spinzi

XLDnaute Impliqué
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
 

Pièces jointes

  • Test Index Equiv Array vSpinzi2.xlsb
    662.8 KB · Affichages: 20

job75

XLDnaute Barbatruc
Bonjour Spinzi, Bebere,

Alors ne pas concaténer tablo(i, 9), modifiez la macro comme suit :
VB:
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

XLDnaute Impliqué
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
 

job75

XLDnaute Barbatruc
Bonjour Spinzi, le forum,

Recherche multicritère ? Dans la macro précédente vous pouvez toujours remplacer :
VB:
If x <> "" And Not d.exists(x) Then d(x) = i 'mémorise le numéro de la 1ère ligne trouvée
par :
VB:
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.
 
Dernière édition:

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof