Fusion de 2BD filtrées selon liste critères et choix des colonnes résultat

Le 11/11/2023 à 19:53

Bien le bonjour ami programmeur !

*** CONTEXTE ***

J'ouvre ce fil dans le cadre du développement que j'entreprends : fusion/consolidation sans doublon de 2 BD selon liste de critères et choix des colonnes résultat.

La quantité de données à gérer obligera à passer par l'utilisation de tableaux array.

  • onglet 1 (bd 1, clé unique en colonne A) : nommé "PRIO"
  • onglet 2 (bd 2, clé unique en colonne A) : nommé "AX"
  • onglet 3 (liste changeante de codes en colonne D qui servent de filtres): nommé "filtres"
  • onglet 4 (bd résultat) : nommé "APPRO"

A savoir :

  • Les bd_AX et bd_PRIO ont certaines colonnes communes, d'autres non. Les emplacements de ces colonnes ne sont de toute façon pas les mêmes. Exception faite de la colonne A : clé.
  • Trois cas de figurent coexistent :
    • CAS 1 : les bd ont des clés communes. Attention ce ne sont pas nécessairement les mêmes données : la bd_AX devra alors être prioritaire sur la bd_PRIO
    • CAS 2 : certaines clés seulement dans la bd_AX
    • CAS 3 : certaines clés seulement dans la bd_PRIO

*** OBJECTIF ***

Réunir dans une bd_résultat l'ensemble des lignes correspondants à 1 ou plusieurs codes listés en colonne D de la feuille "filtres". En n’y conservant que certaines colonnes de la bd_AX et en complétant de certaines colonnes de la bd_PRIO :

  • - AX : indice des colonnes à récupére = Array(1, 3, 5, 6, 4, 18, 26, 30, 7, 8, 9, 10, 13, 11, 16, 17, 20, 21, 19, 14, 23, 12, 40)
  • - PRIO : indice des colonnes à récupérer (si clé non présente dans bd_AX = Array(1, 2, 3, 4, 31, 53, 38, 26, 25, 33, 5, 6, 17, 18, 21, 22, 19, 20, 23, 27)
  • - PRIO : indice des colonnes à ajouter = Array(1, 40, 39, 9, 10, 41)

J'ai débuté le VBA il y a 2 semaines et cela fait déjà 5 jours que je bute sur ce problème en essayant tant bien que mal différentes stratégies.

Aujourd'hui et grâce à l'énorme travail déjà effectué par M Boisgontier je crois pouvoir utiliser dans mon cas, 3 de ses développements (même si je ne conceptualise pas parfaitement la logique du code). A adapter et à appliquer donc.

*** STRATEGIE ***

Elle serait donc la suivante :

1.Déterminer 2 listes regroupant nos 3 cas de figure.

- Liste a. pour CAS1 + CAS2 (clés communes et AX donc prévaut + clés dans AX seulement) : cela revient simplement à créer un array de la BD_AX

- Liste b. pour CAS3 : la bd_PRIO sans les lignes correspondants aux clés de la bd_AX. Donc la liste des différences de clés côté PRIO. Pour cela utilisation de la procédure : Diff()

1a. Array a = array AX :

  • Filtrer cet array en utilisation la liste de clés (feuille "filtres" et colonne "D") en ne gardant que les colonnes qui nous intéressent (array des colonnes à récupérer). Pour cela utilisation de la fonction personnalisée : FiltreArrayCléColRécup(Tbl, clé, colClé, colRécup)

1b. Array b = array PRIO :

  • Même procedure que array AX
  • Redim preserve de l’array PRIO afin de faire correspondre aux dimensions de array AX (ajout de 3 colonnes vides)

2. Création d’un array CONSOLIDATION : array AX + array PRIO

3. Création d’un array COLSUP pour les colonnes à ajouter de la bd_PRIO à l’array CONSOLIDATION (FiltreArrayCléColRécup(Tbl, clé, colClé, colRécup)). Les colonnes à ajouter sont indicées dans un array et liste des clés (feuille "filtres" et colonne "D").

4. Fusion de l’array CONSOLIDATION avec l’array COLSUP. Pour cela utilisation de la procédure : fusion()

5. Transfère du résultat en feuille "APPRO"

*** PROBLEMES RENCONTRES ***

Ils le seront tout au long de ce développement sur ce fil. Ou bien en annexe selon ce qui est la politique de la maison.

Je joins une base test anonymisée et bien allégée (ma version c'est 2 BD de 15000 lignes et plusieurs dizaines de colonnes). Ainsi que les développement de M. Boisgontier : diff ; fusion ; FiltreArrayCléColRécup

D'avance un énorme merci à votre communauté

10projet-anon-light.xlsm (255.97 Ko)
11filtrearrayclecolrecup.zip (92.77 Ko)
11diff.zip (48.96 Ko)
12fusion.zip (17.18 Ko)
Le 11/11/2023 à 19:58

Ma difficulté aujourd'hui est aussi bête que çà, module "mod3_export_approDVP" du projet joint :

Sub Export_APPRO2()
Dim f As Worksheet

Set f = Sheets("AX")
'**** le pas à pas montre que f = Nothing !!
'etc ....
End Sub

Idiot ou aveugle à votre avis ?

Le 12/11/2023 à 00:42

re,

je ne comprends pas ce que vous voulez atteindre. C'est assez compliqué ce que vous faites là.

un essai avec la macro "tomato"

15projet-anon-light-1.zip (286.62 Ko)
Le 12/11/2023 à 02:01

Hey re, le monde est petit ;)

Cette solution ne correspond malheureusement pas au projet : les listes ne fusionnent pas...

Un exemple étant plus parlant : (en orange données communes aux 2 BD)

cléAXcommandecodefournisseurcouleurquantitéprixdevise
CA0110 1567

X

vert10

125

EUR

CA02102567Xnoir1014USD
CA081081095Y2017EUR
CA141014405060Zrouge1088EUR
cléPRIOcommandecodefournisseurquantitédategammecommentairestockVI
CA01101567X60012/11/2023VBbla5TRX56
CA141014405060Z150001/12/2022TTblabla0TRX54
CA85108575830U1414/06/2024PLbliblo89YTO7

On doit obtenir la fusion des deux tableaux : les lignes en communs sont fusionnées en priorisant les données AX, les autres lignes sont importées, et on ne récupère que les colonnes voulues. L'ensemble selon un critère, ici une liste de codes = (567, 1095, 75830)

Résultat final :

clécommandecodefournisseurquantitédategammeprixdevisestock
CA01101567X10 60012/11/2023VB125EUR5
CA02102567X1014USD
CA081081095Y

20

17EUR
CA85108575830U1414/06/2024PL89

Comme évoqué dans le post initial, je pense qu'il serait bon de s'en tenir à la stratégie choisie. Les 3 développements de M Boisgontier font le travail. En l'occurrence il ne me reste plus qu'à adapter son code comme j'ai commencé à le faire dans "mod3_export_approDVP". Cela réduit de beaucoup l'ampleur de la tache et sa complexité. Le rappel de ma problématique du moment étant de faire fonctionner ceci :

Sub Export_APPRO2()
Dim f As Worksheet
Dim LastRow As Integer: Dim LastCol As Integer
Dim TblAX() As Variant: Dim Tbl() As Variant
Dim liste_clé() As Variant: Dim liste_colrécup() As Variant

Set f = Sheets("AX")
LastRow = f.Range("A:A").Find("*", , xlValues, , , xlPrevious).Row
LastCol = f.Cells(1, Columns.Count).End(xlToLeft).Column
TblAX = f.Range(f.Cells(2, 1), f.Cells(LastRow, LastCol)).Value

LastRow = Sheets("filtres").Cells(Rows.Count, "D").End(xlUp).Row
If LastRow < 4 Then
    MsgBox "Il n'y a aucun fournisseur dans la liste !"
    Exit Sub
Else
    liste_clé = Sheets("filtres").Cells(4, "D").Resize(Application.Max(2, LastRow)).Value
End If

liste_colrécup = Array(1, 3, 5, 6, 4, 18, 26, 30, 7, 8, 9, 10, 13, 11, 16, 17, 20, 21, 19, 14, 23, 12, 40)

Tbl = FiltreArrayCléColRécup(TblAX, liste_clé, 1, liste_colrécup)
If Not IsEmpty(Tbl) Then
    Sheets("APPRO").[A2].Resize(UBound(Tbl), UBound(Tbl, 2) - LBound(Tbl, 2) + 1) = Tbl
Else
    MsgBox "Il n'y a aucune ligne de commande concernée dans la source AX !"
End If

End Sub

à l'aide de la fonction suivante :

Option Compare Text
'********************************************
'Fonction FiltreArrayCléColRécup
'
'
'
'*******************************************
Function FiltreArrayCléColRécup(Tbl, clé As Variant, colClé As Integer, colRécup As Variant)
Dim n As Integer: Dim I As Integer: Dim k As Integer
Dim Tbl2()

n = 0
Set d = CreateObject("scripting.dictionary")

For Each c In clé
    d(c) = ""
Next c

For I = 1 To UBound(Tbl)
    If d.exists(Tbl(I, colClé)) Then
        n = n + 1
    End If
Next I
MsgBox n
ReDim Tbl2(1 To n, LBound(colRécup) To UBound(colRécup))
n = 0
For I = 1 To UBound(Tbl)
    If d.exists(Tbl(I, colClé)) Then
        n = n + 1
        For k = LBound(colRécup) To UBound(colRécup)
            Tbl2(n, k) = Tbl(I, colRécup(k))
        Next k
    End If
Next I

If n > 0 Then
    FiltreArrayCléColRécup = Tbl2
End If

End Function
Le 12/11/2023 à 03:03

EDIT de la nuit :

Je continue mon développement et laisse ce sujet ouvert pour mon prochain blocage...

Je réponds à ma question, je suis un idiot et un aveugle ! Le code fonctionne parfaitement, encore faut il choisir la bonne colonne pour filtrer, dans mon cas :

Tbl = FiltreArrayCléColRécup(TblAX, liste_clé, 1, liste_colrécup) ' NON
Tbl = FiltreArrayCléColRécup(TblAX, liste_clé, 5, liste_colrécup) ' OUI
Le 12/11/2023 à 03:33

re,

si vous prenez toutes les colonnes de "Appro", quelles colonnes de AX et de Prio correspondent avec cà ?

donc 3 lignes

ligne 1 = la ligne juste en dessous "Résultat final"

ligne 2 = les numéros des colonnes de AX qui correspondent avec ligne 1 (si elles ne sont pas dans AX, alors 0)

ligne 3 = les numéros des colonnes de PRIO qui correspondent avec ligne 1 (si elles ne sont pas dans PRIO, alors 0)

si je sais cela, on peut résoudre cela avec la macro de 00:42, tout le reste est trop compliqué.

Le 12/11/2023 à 19:49

bon, les 2 premières lignes de "APPRO" ce sont les entêtes des colonnes de chaque des feuilles qu'on veut récupérer dans Appro

les 2 lignes suivantes sont l'index de ces colonnes.

Vous pouvez ajouter autant de colonnes que vous voulez et les noms des colonnes de AX et de PRIO ne sont pas nécessairement égaux.

14projet-anon-light-2.xlsm (270.94 Ko)
Le 13/11/2023 à 03:47

Amis insomniaques bonsoir/bonjour,

Sujet résolu et sacré développement pour un débutant

Bien évidemment tout cela n'aurait jamais été possible sans M Jacques Boisgontier... 

'COLONNES COMMUNES              "PRIO"   "AX"    COLONNES COMMUNES
'                                1 A      A 1    Clé
'                                2 B      C 3    Code gestionnaire
'                                3 C      E 5    Compte fournisseur
'                                4 D      F 6    Nom (frs)
'                                31 AE    D 4    Date et heure de création
'                                53 BA    R 18   Statut d'approbation
'                                38 AL    Z 26   Origine de prix
'                                26 Z     AD 30  Référence commande EDI
'                                25 Y     G 7    Commande fournisseur
'                                33 AG    H 8    Numéro de ligne
'                                5 E      I 9    Numéro d'article
'                                6 F      J 10   Nom2 (designation)
'                                17 Q     M 13   Quantité
'                                18 R     K 11   Livrer quantité restante
'                                21 U     P 16   Date d'enlèvement
'                                22 V     Q 17   Date d'enlèvement confirmée
'                                19 S     T 20   Date de livraison
'                                20 T     U 21   Date de livraison confirmée
'                                23 W     S 19   Commentaires
'COLONNES DANS AX SEULEMENT               N 14   Prix unitaire
'                                         W 23   Devise
'                                         L 12   Unité
'                                         AN 40  Géré PAG
'COLONNES DANS PRIO SEULEMENT
'Acheteur                        40 AN
'Gamme                           39 AM
'DATE DE BESOIN "REACTUALISEE"   9 I
'Prio                            10 J
'Stock Dispo                     41 AO
'
'AX = Array(1, 3, 5, 6, 4, 18, 26, 30, 7, 8, 9, 10, 13, 11, 16, 17, 20, 21, 19, 14, 23, 12, 40)
'PRIO = Array(1, 2, 3, 4, 31, 53, 38, 26, 25, 33, 5, 6, 17, 18, 21, 22, 19, 20, 23)
'PRIO a ajouter = Array(40, 39, 9, 10, 41)
Option Explicit
Sub Export_APPRO()
Dim TblAX() As Variant: Dim a() As Variant
Dim TabDiff() As Variant: Dim DicoDiff As Object
Dim TblPRIO() As Variant: Dim b0() As Variant: Dim b() As Variant
Dim TblConsolid() As Variant: Dim TblAdding() As Variant
Dim dico As Object: Dim TblResult As Variant
Dim Tab1() As Variant: Dim Tab2() As Variant
Dim liste_clé() As Variant: Dim liste_colrécup() As Variant
Dim colClé As Integer: Dim LastRow As Integer
Dim I As Integer: Dim k As Integer
Dim n As Integer: Dim p As Integer
Dim t, r, c

t = Timer

'test si existe filtre fournisseur
LastRow = Sheets("filtres").Cells(Rows.Count, "D").End(xlUp).Row
If LastRow < 4 Then
    MsgBox "Il n'y a aucun fournisseur dans la liste !"
    Exit Sub
End If

'A] ARRAY a : AX
TblAX = Sheets("AX").Range("A1").CurrentRegion.Value2
liste_clé = Sheets("filtres").Cells(4, "D").Resize(Application.Max(2, LastRow)).Value
liste_colrécup = Array(1, 3, 5, 6, 4, 18, 26, 30, 7, 8, 9, 10, 13, 11, 16, 17, 20, 21, 19, 14, 23, 12, 40)
colClé = 5
a = FiltreArrayCléColRécup(TblAX, liste_clé, colClé, liste_colrécup)

'B] ARRAY b : PRIO
'1) dico des clés qui n'existent que dans PRIO
Tab1 = Sheets("PRIO").Range("$A$2:$A" & Sheets("PRIO").[A15000].End(xlUp).Row).Value2
Tab2 = Sheets("AX").Range("$A$2:$A" & Sheets("AX").[A15000].End(xlUp).Row).Value2
TabDiff = Diff(Tab1, Tab2)
Set DicoDiff = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(TabDiff)
    If TabDiff(I, 1) <> "" Then
        DicoDiff(TabDiff(I, 1)) = I
    End If
Next I

'2) array b0 filtré sur fournisseurs + choix colonnes résultat
TblPRIO = Sheets("PRIO").Range("A1").CurrentRegion.Value2
liste_clé = Sheets("filtres").Cells(4, "D").Resize(Application.Max(2, LastRow)).Value
liste_colrécup = Array(1, 2, 3, 4, 31, 53, 38, 26, 25, 33, 5, 6, 17, 18, 21, 22, 19, 20, 23)
colClé = 3
b0 = FiltreArrayCléColRécup(TblPRIO, liste_clé, colClé, liste_colrécup)

'3)Finalisation ARRAY b
'redim de b
n = 0
For I = 1 To UBound(b0)
    If DicoDiff.Exists(b0(I, 1)) Then
        n = n + 1
    End If
Next I
ReDim b(1 To n, 1 To UBound(b0, 2))
'introduction des lignes dans ARRAY b
n = 0
For I = 1 To UBound(b0)
    If DicoDiff.Exists(b0(I, 1)) Then
        n = n + 1
        For k = 1 To UBound(b0, 2)
            b(n, k) = b0(I, k)
        Next k
    End If
Next I
'égalisation taille de array b sur array a
ReDim Preserve b(1 To n, 1 To UBound(a, 2))

'C] CONSOLIDATION des ARRAY a et b
n = UBound(a)
ReDim TblConsolid(1 To UBound(a) + UBound(b), 1 To UBound(a, 2))
For I = LBound(a) To UBound(a)
    For c = 1 To UBound(a, 2)
        TblConsolid(I, c) = a(I, c)
    Next c
Next I
For I = 1 To UBound(b)
    For c = 1 To UBound(b, 2)
        TblConsolid(n + I, c) = b(I, c)
    Next c
Next I

'D] FUSION TblConsolid avec TblAdding
'TblAdding = TblPRIO sur filtre fournisseur et chox colonnes
TblPRIO = Sheets("PRIO").Range("A1").CurrentRegion.Value2
liste_clé = Sheets("filtres").Cells(4, "D").Resize(Application.Max(2, LastRow)).Value
liste_colrécup = Array(1, 40, 39, 9, 10, 41)
colClé = 3
TblAdding = FiltreArrayCléColRécup(TblPRIO, liste_clé, colClé, liste_colrécup)
'Fusion
Set dico = CreateObject("Scripting.Dictionary")
n = UBound(TblConsolid, 2) + UBound(TblAdding, 2)
ReDim TblResult(1 To UBound(TblConsolid), 1 To n)
'étude de TblConsolid et dico indexant la colonne A (clé)
p = 0
For I = LBound(TblConsolid) To UBound(TblConsolid)
    p = p + 1
    dico(TblConsolid(I, 1)) = p
    For k = 1 To UBound(TblConsolid, 2)
        TblResult(p, k) = TblConsolid(I, k)
    Next k
Next I
'étude de TblAdding (les colonnes à ajouter) à la suite du tableau selon l'indexation du dico
For I = LBound(TblAdding) To UBound(TblAdding)
    p = dico(TblAdding(I, 1))
    For k = 2 To UBound(TblAdding, 2) ' k=2 car on retire la colonne clé
        TblResult(p, (UBound(TblConsolid, 2) + k - 1)) = TblAdding(I, k) ' k-1 car on a retiré une colonne
    Next k
Next I

With Sheets("APPRO")
    .UsedRange.ClearContents
    .[A2].Resize(UBound(TblResult), UBound(TblResult, 2) - LBound(TblResult, 2) + 1) = TblResult
End With

MsgBox UBound(TblResult) & " ligne(s) de commande(s) exportée(s) avec succès !" & vbLf _
        & "temps nécessaire : " & Format(Timer - t, "0.00\s")

'Il manquera la ligne d'en tête de tableau et le formatage des différentes colonnes pour faire bien
'ainsi que la gestion des erreurs

End Sub
Option Compare Text
'********************************************
'Fonction FiltreArrayCléColRécup
'
'
'
'*******************************************
Function FiltreArrayCléColRécup(Tbl, clé As Variant, colClé As Integer, colRécup As Variant)
Dim n As Integer: Dim I As Integer: Dim k As Integer
Dim Tbl2()

n = 0
Set d = CreateObject("scripting.dictionary")

For Each c In clé
    d(c) = ""
Next c

For I = 1 To UBound(Tbl)
    If d.Exists(Tbl(I, colClé)) Then
        n = n + 1
    End If
Next I

ReDim Tbl2(1 To n, 1 To (UBound(colRécup) + 1))
n = 0
For I = 1 To UBound(Tbl)
    If d.Exists(Tbl(I, colClé)) Then
        n = n + 1
        For k = 1 To (UBound(colRécup) + 1)
            Tbl2(n, k) = Tbl(I, colRécup(k - 1))
        Next k
    End If
Next I

If n > 0 Then
    FiltreArrayCléColRécup = Tbl2
End If

Erase Tbl2
Erase Tbl

End Function
'********************************************
'Fonction Diff
'ne fonctionne que sur array à 1D (monocolonne)
'Diff(tab1, tab2) retourne les données non communes de tab1
'Diff(tab2, tab1) retourne les données non communes de tab2
'*******************************************
Function Diff(Tab1, Tab2)

Set MonDico1 = CreateObject("Scripting.Dictionary")
For Each c In Tab2
    tmp = c: MonDico1(tmp) = ""
Next c

Set mondico2 = CreateObject("Scripting.Dictionary")
For Each c In Tab1
    tmp = c
    If Not MonDico1.Exists(tmp) Then
        mondico2(tmp) = ""
    End If
Next c

Dim d()
On Error Resume Next
tmp = Application.Caller.Rows.Count

If Err = 0 Then
    ReDim d(1 To Application.Caller.Rows.Count)
Else
    ReDim d(1 To MonDico1.Count)
End If
On Error GoTo 0

I = 1
For Each c In mondico2.keys
    d(I) = c
    I = I + 1
Next c

Diff = Application.Transpose(d)

Erase Tab1
Erase Tab2

End Function

Bonne nuit et merci encore @BsAlv

Le 13/11/2023 à 06:58

re,

pouvez-vous aussi ajouter le fichier en PJ ? (j'ai une erreur "9" avec ces macros et fonctions)

Le 14/11/2023 à 01:40

Hello,

Effectivement... Je pense que le code est en échec lorsqu'il n'y a pas de données supplémentaires de la BD PRIO à intégrer.

Je vais essayer de trouver le temps de continuer à travailler dessus pour corriger cela et je proposerais quelque chose de stable une fois terminé ✌️

Le 14/11/2023 à 08:06
12projet-anon-light-2.zip (367.84 Ko)
Le 14/11/2023 à 15:08

Hello Bart,

En réalité il y a avait 2 erreurs :

1/ Le premier plantage vient du fait qu'il faille effectuer la conversion des données de la colonne 5 de "AX" en "standard". Comme je ne ne sais pas faire cette opération en VBA, je l'ai fait manuellement avec l'utilitaire de conversation déjà intégré dans excel.

2/ Sinon voici le code corrigé et opérationnel :

'COLONNES COMMUNES              "PRIO"   "AX"    COLONNES COMMUNES
'                                1 A      A 1    Clé
'                                2 B      C 3    Code gestionnaire
'                                3 C      E 5    Compte fournisseur
'                                4 D      F 6    Nom (frs)
'                                31 AE    D 4    Date et heure de création
'                                53 BA    R 18   Statut d'approbation
'                                38 AL    Z 26   Origine de prix
'                                26 Z     AD 30  Référence commande EDI
'                                25 Y     G 7    Commande fournisseur
'                                33 AG    H 8    Numéro de ligne
'                                5 E      I 9    Numéro d'article
'                                6 F      J 10   Nom2 (designation)
'                                17 Q     M 13   Quantité
'                                18 R     K 11   Livrer quantité restante
'                                21 U     P 16   Date d'enlèvement
'                                22 V     Q 17   Date d'enlèvement confirmée
'                                19 S     T 20   Date de livraison
'                                20 T     U 21   Date de livraison confirmée
'                                23 W     S 19   Commentaires
'COLONNES DANS AX SEULEMENT               N 14   Prix unitaire
'                                         W 23   Devise
'                                         L 12   Unité
'                                         AN 40  Géré PAG
'COLONNES DANS PRIO SEULEMENT
'Acheteur                        40 AN
'Gamme                           39 AM
'DATE DE BESOIN "REACTUALISEE"   9 I
'Prio                            10 J
'Stock Dispo                     41 AO
'
'AX = Array(1, 3, 5, 6, 4, 18, 26, 30, 7, 8, 9, 10, 13, 11, 16, 17, 20, 21, 19, 14, 23, 12, 40)
'PRIO = Array(1, 2, 3, 4, 31, 53, 38, 26, 25, 33, 5, 6, 17, 18, 21, 22, 19, 20, 23)
'PRIO a ajouter = Array(40, 39, 9, 10, 41)
Option Explicit
Sub Export_APPRO()
Dim TblAX() As Variant: Dim a() As Variant
Dim TabDiff() As Variant: Dim DicoDiff As Object
Dim TblPRIO() As Variant: Dim b0() As Variant: Dim b() As Variant
Dim TblConsolid() As Variant: Dim TblAdding() As Variant
Dim dico As Object: Dim TblResult As Variant
Dim Tab1() As Variant: Dim Tab2() As Variant
Dim liste_clé() As Variant: Dim liste_colrécup() As Variant
Dim colClé As Integer: Dim LastRow As Integer
Dim I As Integer: Dim k As Integer
Dim n As Integer: Dim p As Integer
Dim t, r, c

t = Timer

'test si existe filtre fournisseur
LastRow = Sheets("filtres").Cells(Rows.Count, "D").End(xlUp).Row
If LastRow < 4 Then
    MsgBox "Il n'y a aucun fournisseur dans la liste !"
    Exit Sub
End If

'A] ARRAY a : AX
TblAX = Sheets("AX").Range("A1").CurrentRegion.Value2
liste_clé = Sheets("filtres").Cells(4, "D").Resize(Application.Max(2, LastRow)).Value
liste_colrécup = Array(1, 3, 5, 6, 4, 18, 26, 30, 7, 8, 9, 10, 13, 11, 16, 17, 20, 21, 19, 14, 23, 12, 40)
colClé = 5
a = FiltreArrayCléColRécup(TblAX, liste_clé, colClé, liste_colrécup)

'B] ARRAY b : PRIO
'1) dico des clés qui n'existent que dans PRIO
Tab1 = Sheets("PRIO").Range("$A$2:$A" & Sheets("PRIO").[A15000].End(xlUp).Row).Value2
Tab2 = Sheets("AX").Range("$A$2:$A" & Sheets("AX").[A15000].End(xlUp).Row).Value2
TabDiff = Diff(Tab1, Tab2)
Set DicoDiff = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(TabDiff)
    If TabDiff(I, 1) <> "" Then
        DicoDiff(TabDiff(I, 1)) = I
    End If
Next I

'2) array b0 filtré sur fournisseurs + choix colonnes résultat
TblPRIO = Sheets("PRIO").Range("A1").CurrentRegion.Value2
liste_clé = Sheets("filtres").Cells(4, "D").Resize(Application.Max(2, LastRow)).Value
liste_colrécup = Array(1, 2, 3, 4, 31, 53, 38, 26, 25, 33, 5, 6, 17, 18, 21, 22, 19, 20, 23)
colClé = 3
b0 = FiltreArrayCléColRécup(TblPRIO, liste_clé, colClé, liste_colrécup)

'3)Finalisation ARRAY b
'redim de b
n = 0
For I = 1 To UBound(b0)
    If DicoDiff.Exists(b0(I, 1)) Then
        n = n + 1
    End If
Next I
'comptage des lignes qu'il y aura à ajouter
If Not n = 0 Then
    ReDim b(1 To n, 1 To UBound(b0, 2))
    'introduction des lignes dans ARRAY b
    n = 0
    For I = 1 To UBound(b0)
        If DicoDiff.Exists(b0(I, 1)) Then
            n = n + 1
            For k = 1 To UBound(b0, 2)
                b(n, k) = b0(I, k)
            Next k
        End If
    Next I
    'égalisation taille de array b sur array a
    ReDim Preserve b(1 To n, 1 To UBound(a, 2))

    'C] CONSOLIDATION des ARRAY a et b
    n = UBound(a)
    ReDim TblConsolid(1 To UBound(a) + UBound(b), 1 To UBound(a, 2))
    For I = LBound(a) To UBound(a)
        For c = 1 To UBound(a, 2)
            TblConsolid(I, c) = a(I, c)
        Next c
    Next I
    For I = 1 To UBound(b)
        For c = 1 To UBound(b, 2)
            TblConsolid(n + I, c) = b(I, c)
        Next c
    Next I
Else
    TblConsolid = a
End If

'D] FUSION TblConsolid avec TblAdding
'TblAdding = TblPRIO sur filtre fournisseur et chox colonnes
TblPRIO = Sheets("PRIO").Range("A1").CurrentRegion.Value2
liste_clé = Sheets("filtres").Cells(4, "D").Resize(Application.Max(2, LastRow)).Value
liste_colrécup = Array(1, 40, 39, 9, 10, 41)
colClé = 3
TblAdding = FiltreArrayCléColRécup(TblPRIO, liste_clé, colClé, liste_colrécup)
'Fusion
Set dico = CreateObject("Scripting.Dictionary")
n = UBound(TblConsolid, 2) + UBound(TblAdding, 2)
ReDim TblResult(1 To UBound(TblConsolid), 1 To n)
'étude de TblConsolid et dico indexant la colonne A (clé)
p = 0
For I = LBound(TblConsolid) To UBound(TblConsolid)
    p = p + 1
    dico(TblConsolid(I, 1)) = p
    For k = 1 To UBound(TblConsolid, 2)
        TblResult(p, k) = TblConsolid(I, k)
    Next k
Next I
'étude de TblAdding (les colonnes à ajouter) à la suite du tableau selon l'indexation du dico
For I = LBound(TblAdding) To UBound(TblAdding)
    p = dico(TblAdding(I, 1))
    For k = 2 To UBound(TblAdding, 2) ' k=2 car on retire la colonne clé
        TblResult(p, (UBound(TblConsolid, 2) + k - 1)) = TblAdding(I, k) ' k-1 car on a retiré une colonne
    Next k
Next I

With Sheets("APPRO")
    .UsedRange.ClearContents
    .[A2].Resize(UBound(TblResult), UBound(TblResult, 2) - LBound(TblResult, 2) + 1) = TblResult
End With

MsgBox UBound(TblResult) & " ligne(s) de commande(s) exportée(s) avec succès !" & vbLf _
        & "temps nécessaire : " & Format(Timer - t, "0.00\s")

'Il manquera la ligne d'en tête de tableau et le formatage des différentes colonnes pour faire bien

End Sub
18projet-anon-light.xlsm (249.87 Ko)
Le 14/11/2023 à 15:15

Sheets("AX").Columns("E:E").NumberFormat = "General"

Le 14/11/2023 à 15:24

Je suis en train de lire ton code, et c'est vraiment très bien mieux !

Je vais finir la lecture et faire des tests mais ca permet 1) une belle simplification ; 2) à l'utilisateur de ne pas avoir à entrer dans du code pour modifier les colonnes à importer

Bravo !

Le 14/11/2023 à 16:11

Bart il semble que ton code ne fonctionne pas lorsqu'un seul fournisseur dans la colonne D (feuille "filtres") est sélectionné ... et je ne sais pas corriger l'erreur

Le 14/11/2023 à 21:04

Résolu en trichant sur le range filtres ;)

With Sheets("Filtres")
     aFiltres = .Range("D4:D" & (.Range("D" & Rows.Count).End(xlUp).Row + 1)).Value2
End With
Le 14/11/2023 à 21:54

re,

quand on n'a qu'un fournisseur unique, aFiltres sera un double ou un string et ne pas un array. Votre solution est okay, mais alors on a aussi une valeur "vide". Si cela provoque des anomalies, on prend aussi un élément supplémentaire (comme vous l'avez fait) et puis un fait un "Redim" sur la dernière dimension (sur une autre dimension n'est pas possible), mais comme on avait un array 2D et je veux un array 1D, on doit le transposer et puis on fait ce "Redim"

     With Sheets("Filtres")
          X = .Range("D" & Rows.Count).End(xlUp).Row - 3 'nombre d'éléments
          aFiltres = Application.Transpose(.Range("D4").Resize(Application.Max(2, X)).Value2) '     'lire les filtres, minimum 2 pour avoir un array
          If X = 1 Then ReDim Preserve aFiltres(1 To 1)
      End With

Il y a aussi une macro "Copy_Format", on peut utiliser une fois pour avoir les mêmes formats numériques que dans la source.

Je vois qu'il y a encore une MFC dans ma feuille pour comparer avec la feuille "APPRO", mais vous pouvez la supprimer.

Rechercher des sujets similaires à "fusion 2bd filtrees liste criteres choix colonnes resultat"