Liste consolidée filtrée multicritère utilisant Array et/ou dictionary

Le 09/11/2023 à 02:56

Bonjour à tous,

Je commence par le vif du sujet pour faciliter la lecture de gens qui comme moi passent des heures à lire des sujets pour se dépanner :

Objectif : virtualiser une base de donnée dans un array ou un dictionnaire pour relever l'ensemble des clés qui correspondent à un critère donné.

Une feuille base de donnée dans "PRIO" : clés en colonne A ; codes en colonne C.

La feuille "filtre" liste en colonne "D" l'ensemble des codes servant de critère.

En feuille "APPRO" je souhaite récupérer la liste exhaustive des clés qui correspondent aux critères "codes".

Bonus : a cela s'ajoute l'existence d'une seconde base de données "AX" (clés colonne A ; codes colonne E) qui est l'image actualisée de "PRIO" et dont il faudra venir puiser là aussi la liste exhaustive des clés correspondants aux critères "codes" sans créer de doublon cependant.

J'ai commencé mes premiers programmes il y une semaine et malgré de longues lectures et recherches je peine à utiliser correctement les tableaux et dictionnaires.

Le travail s'effectue sur une quantités de données (2BD de 15000 lignes) et obligatoirement en VBA. Si pas d'utilisation de tableau ou de dico ca met un temps monstre donc on écarte.

Solution qui me semble adaptée :

1/ passer la BD "PRIO" en array ;

1optionnel/ passer la liste des critères en array ;

2/double boucle : sur chaque ligne de l'array dont le code appartient à la liste de critères-code : ajouter le couple clé + code à un dictionnaire (ou un nouvel array) ;

3/réitérer avec la BD "AX" puis dégommer les doublons

4/ coller cette liste à 2 colonnes dans la feuille "APPRO"

Je but depuis 2 jours sur ce problème que je n'arrive pas à contourner de par mon inexpérience car il s'agit à mon avis, d'un problème de qualification de variables ou autre aspect élémentaire mais voila... je bloque !

Merci d'avance à vous qui voudrez vous pencher sur mon problème et m'apporter votre aide : fichier en PJ + bout de code suivant : jusqu'à REPERE 1 rien d'intéressant ;)

Option Explicit
Sub Export_APPRO2()
'On Error Resume Next
Dim MonDico As Object
Dim I As Integer: Dim k As Integer: Dim n As Integer
Dim LastRow As Integer
Dim TblPRIO() As Variant
Dim TblAX() As Variant

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

LastRow = Sheets("filtres").Cells(Rows.count, "D").End(xlUp).Row
n = LastRow
If n < 4 Then
MsgBox "Il n'y a aucun fournisseur dans la liste !"
Else
'Clear des anciens clé_CONCATENER du fichier APPRO
LastRow = Sheets("APPRO").Cells(Rows.count, "A").End(xlUp).Row
If Not LastRow < 2 Then
Sheets("APPRO").Range("$A$2:$B" & LastRow).ClearContents
End If

Set MonDico = Nothing
Set MonDico = CreateObject("Scripting.Dictionary")
Barre_progression.afficher

LastRow = Sheets("PRIO").[A15000].End(xlUp).Row
TblPRIO = Sheets("PRIO").Range("$A$2:$C" & LastRow).Value
'******************************REPERE 1******************************
Debug.Print TblPRIO(1, 3) 'LECTURE IMPOSSIBLE
'******************************REPERE 1******************************
'Les clé_CONCATENER/Item_PARMA#C du PRIO sont ajoutées à MonDico si parma dans la liste des frn
For k = 4 To n
Barre_progression.actualiser "Export commandes PRIO...", CInt(99 * ((k - 3) / (n - 3)))
For I = 0 To UBound(TblPRIO, 1)
'******************************REPERE 2******************************
If Sheets("filtres").Cells(k, "D").Value = TblPRIO(I, 3) Then 'pas certain de pouvoir comparer ces valeurs comme ceci
'******************************REPERE 2******************************
MonDico.Add TblPRIO(I, 1), _
TblPRIO(I, 3)
End If
Next I
Next k

'******************************SUITE DU CODE : problème sera équivalent******************************

LastRow = Sheets("AX").[A15000].End(xlUp).Row
TblAX = Sheets("AX").Range("$A$2:$E" & LastRow).Value
'Les clé_CONCATENER/Item_PARMA#E du AX sont ajoutées à MonDico si n'y figuraient pas déjà et si parma dans la liste des frn
For k = 4 To n
Barre_progression.actualiser "Export commandes AX...", CInt(99 * ((k - 3) / (n - 3)))
For I = 0 To UBound(TblAX)
If Sheets("filtres").Cells(k, "D").Value = TblAX(I, 5) Then
If Not MonDico.Exists(TblAX(I, 1)) Then
MonDico.Add TblAX(I, 1), _
TblAX(I, 5)
End If
End If
Next I
Next k

n = MonDico.count
Sheets("APPRO").[$A$2].Resize(MonDico.count) = Application.Transpose(MonDico.keys)
Sheets("APPRO").[$B$2].Resize(MonDico.count) = Application.Transpose(MonDico.items)

Set MonDico = Nothing
MsgBox n & " ligne(s) de commande(s) exportée(s) avec succès !"

End If

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Barre_progression.actualiser "Export...", CInt(100)

End Sub
19projet-anon-light.zip (292.65 Ko)
Le 09/11/2023 à 08:55

bonjour tomato,

j'ai modifié un petit peu votre macro. Ces "progresbar" ne servent qu'à ralentir la macro

14projet-anon-light.zip (274.80 Ko)
Le 09/11/2023 à 10:26

Bonjour et mille mercis Bart pour votre réponse + que bienvenue !

Une bonne et une mauvaise nouvelle: ca fonctionne .. mais qu'à moitié.

Le code est opérationnel mais les nouvelles clés dans la BD "AX" ne sont pas intégrées.. et je ne l'explique pas !

Quelques commentaires ci après :

Option Explicit
Sub Export_APPRO2()
     'On Error Resume Next
     Dim MonDico As Object
     Dim I As Integer: Dim k As Integer: Dim n As Integer
     Dim LastRow As Integer
     Dim TblPRIO() As Variant
     Dim TblAX() As Variant
     Dim X, r, t                             'les 2 sont variant !!!

     t = Timer

     LastRow = Sheets("filtres").Cells(Rows.Count, "D").End(xlUp).Row
     n = LastRow
     If n < 4 Then
          MsgBox "Il n'y a aucun fournisseur dans la liste !"
     Else
          X = Sheets("filtres").Cells(4, "D").Resize(Application.Max(2, n)).Value     'array temporaire de D
'*****1/5: pourquoi déclarer "Dim X As Variant" et non pas "Dim X() As Variant ?"*****

          'Clear des anciens clé_CONCATENER du fichier APPRO
          LastRow = Sheets("APPRO").Cells(Rows.Count, "A").End(xlUp).Row
          If Not LastRow < 2 Then Sheets("APPRO").Range("$A$2:$B" & LastRow).ClearContents

          Set MonDico = CreateObject("Scripting.Dictionary")

          LastRow = Sheets("PRIO").[A15000].End(xlUp).Row
          TblPRIO = Sheets("PRIO").Range("$A$2:$C" & LastRow).Value
          'Les clé_CONCATENER/Item_PARMA#C du PRIO sont ajoutées à MonDico si parma dans la liste des frn
          For I = 1 To UBound(TblPRIO, 1)
'*****2.1/5 : pourquoi ne démarre t on pas à I = -1 ? Nous n'avons pourtant pas déclaré de base 1 sur l'array... ;*****
'*****2.2/5 : Est ce que "UBound(TblPRIO, 1)" peut se simplifier à "UBound(TblPRIO)" ?*****

               If IsNumeric(r) Then
               r = Application.Match(TblPRIO(I, 3), X, 0)     'clé existe ?
'*****3/5 : j'aurais eu le réflex de boucler dans la boucle sur chaque valeur dans X dans le genre de "For J = -1 To UBound(X)" et "r = Application.Match(TblPRIO(I, 3), X(J), 0)". Le fait d'utiliser X "seul" permet de s'en affranchir c'est bien ca ?"*****

               If IsNumeric(r) Then
                    If Not MonDico.exists(TblPRIO(I, 1)) Then MonDico.Add TblPRIO(I, 1), TblPRIO(I, 3)     'non = ajouter au dictionaire
               End If
          Next I

          LastRow = Sheets("AX").[A15000].End(xlUp).Row
          TblAX = Sheets("AX").Range("$A$2:$E" & LastRow).Value
          'Les clé_CONCATENER/Item_PARMA#E du AX sont ajoutées à MonDico si n'y figuraient pas déjà et si parma dans la liste des frn
          For I = 1 To UBound(TblAX)
               r = Application.Match(TblAX(I, 5), X, 0)     'clé existe ? 
               If IsNumeric(r) Then
                    If Not MonDico.exists(TblAX(I, 1)) Then MonDico.Add TblAX(I, 1), TblAX(I, 5)     'oui = ajouter au dictionaire
'*****4/5 : j'ai juste modifié de "TblAX(I, 3)" à TblAX(I, 5) car on cherche la colonne critère en "E" et plus "D""*****

               End If
          Next

          If MonDico.Count > 0 Then
               Sheets("APPRO").[$A$2].Resize(MonDico.Count) = Application.Transpose(MonDico.keys)
               Sheets("APPRO").[$B$2].Resize(MonDico.Count) = Application.Transpose(MonDico.items)
               MsgBox MonDico.Count & " ligne(s) de commande(s) exportée(s) avec succès !" & vbLf & "temps nécessaire : " & Format(Timer - t, "0.00\s")
          End If
          Set MonDico = Nothing

     End If

End Sub

'*****5/5 : malheureusement après essai je constate que les nouvelles clés qui peuvent être uniquement présentes dans la BD "AX" ne sont pas relevées... je ne l'explique pas"*****
Le 09/11/2023 à 11:17

re,

Déclarer les variables, bon, il y a (en binaire) 10 sorte de personnes, ceux qui le font et le reste et moi je me situe dans le 2eme groupe (par conviction, pas par paresse et la déclaration, ce n'est que'une détection vite d'erreur).

Ce X est une variable auxiliaire polyvalente temporaire que j'utilise partout pour quelque chose de courte durée, un moment, il est variant, un moment plus tard double ou ... juste pour quelque lignes dans la macro. Ici, c'est temporairement le contenu de la colonne D de "Filtres"

Si on lit le contenu d'une plage, le "LBound" (sorte de limite inférieure) est 1 et ne pas 0.

Oui, UBound(TblPRIO, 1)=UBound(TblPRIO)

Vous parlez de 15.000 lignes et par exemple 20 clés dans filtre, alors il faut boucler ces 15.000 lignes 20 fois, maintenant seulement 1 fois, donc 20 fois plus vite. Si vous voulez un triage sur ce clé, on peut le faire après dans la feuille "Appro".

J'ai déclaré "r" comme variant, le résultat du "application.match" sera un chiffre (clé présent) ou une erreur (clé n'existe pas), mais comme r est variant, la macro ne s'arrête pas et la ligne suivante, je n'ai qu'à vérifier si r est numérique donc le clé est présent dans la colonne D de "filtres".

oui, ce TblAX(I, 5) était faux.

'*****5/5 : malheureusement après essai je constate que les nouvelles clés qui peuvent être uniquement présentes dans la BD "AX" ne sont pas relevées... je ne l'explique pas"*****

Vous voulez des clés qui n'existent pas encore dans la colonne D de "filtres" ? Alors, c'est inverse et il faut ajouter "not" a cette ligne

 If not IsNumeric(r) Then
Le 09/11/2023 à 12:45

Merci beaucoup pour tes réponses et ton aide.

Je place le sujet résolu.

En effet, la non détection des clés de la seconde BD venait du fait que dans cette BD là, les données de la colonne A (clés) n'étaient pas des valeurs en dur mais des formules qui pouvait renvoyer une chaine vide (= "").

J'ai résolu la situation en détectant la dernière ligne comme suit :

LastRow = Sheets("AX").Range("A:A").Find("*", , xlValues, , , xlPrevious).Row

Merci à toi de faire vivre cet espace d'entre aide et d'apprentissage. Bonne continuation :)

Le 09/11/2023 à 15:07

re, attention, ce "lastrow" ignore les cellules invisibles (=filtré) de la colonne A, donc supposons que A1000<>"" mais sa ligne est filtrée/cachée et le résultat suivant est A100 qui est visible, alors LastRow=100 !!!!

Alors, commencer avec un reset des filtres oubien une fonction personnalisée.

Sub Teste()
     MsgBox DerniereLigne_ColA("AX", 1000)   'se limiter aux premiere 1.000 lignes
     MsgBox DerniereLigne_ColA("AX")         'la colonne A complète
End Sub

Function DerniereLigne_ColA(Feuille As String, Optional MaxLignes As Long)
     If MaxLignes = 0 Then MaxLignes = Rows.Count
     Sheets(Feuille).Range("A1").Resize(MaxLignes).Name = "My_A"
     x = Evaluate("iferror(aggregate(14,6,row(my_A)/(my_a<>""""),1),0)")
     DerniereLigne_ColA = IIf(x = 0, "Erreur", x)
End Function

ou des autres propositions ....

Le 09/11/2023 à 15:46

L'information qui... ne m'arrange pas :(

Je n'ai pas assez de skills pour comprendre ta fonction pour le moment. Je pense donc me diriger vers un lastrow de la colonne B de ma BD "AX" (normalement il y en a autant que de clés) mais ce n'est pas idéal.

C'est dingue qu'il n'y ait pas une bidouille en une ligne simple pour trouver un .end(XlUp) and <> "" :(

Merci tout de même :/

Le 09/11/2023 à 17:30

c'est simple, n'utilisez pas l'autofilter avant de chercher la dernière ligne.

Rechercher des sujets similaires à "liste consolidee filtree multicritere utilisant array dictionary"