[VBA Excel 2013] Extraction de données basé sur 2 à 3 conditions

Bonjour à tous,

J'ai une base de données (feuille Database) qui références des producteurs d'ingrédients, le type d'ingrédient, la référence commerciale et les caractéristiques techniques de chaque référence.

Je souhaiterais créer un outil pour faciliter la consultation des caractéristiques des références. L'accès aux données de la référence se fera après sélection de 3 critères : le producteur, le type et la référence.

Voici ce que j'ai déjà mis en place. Je joins un fichier anonymisé.

Sur la page Home, il y a 3 listes déroulantes en activex pour sélectionner les paramètres. À l'ouverture du fichier, une liste des producteurs sans doublons est générée sur la page construction, colonne B et ensuite chargé dans la liste déroulante correspondante. À la sélection d'un producteur via la liste déroulante, une liste des types de produits et eds références associées a ce producteur sont générée sur la feuille construction, en colonne D et F, et chargé dans la liste déroulante correspondante. À la sélection d'un type de produit , la liste référence est régénérée en tenant compte du double critère Producteur&Type de produit.

À chaque sélection dans les listes déroulantes, l'information est répercutée sur la page construction, en I6:K6, ce qui servira ensuite pour l'extraction des données.

Pour l'extraction, lorsqu'on modifie la sélection dans une liste (macros sur Home, List_conc_Change, List_ref_Change et List_type_Change), cela appelle la macro "extraire" du module 12. Cette macro va balayer la BDD de la feuille Database et récupérer la/les numéros de ligne(s) de cette BDD qui valide(nt) les conditions définies dans le range I6:K6 via les listes déroulantes. Les 4 cas de figure sont :

• Seul I6 (producteur) est complété
• I6 (producteur) et J6 (type de produit) sont complétés
• I6 (producteur) et K6(références) sont complétés
• I6, J6 et K6 sont complétés (dans cas il n'y aura qu'une ligne a extraire)

Voici le code correspondant

Sub extraire()

Dim ligne_listes As Integer
Dim ligne_bd As Integer

If (Range("I6").Value = "" And Range("J6").Value = "" And Range("K6").Value = "") Then
Exit Sub
End If

'efface les donnée récupérées précédement
ligne_listes = 10
While (Sheets("construction").Cells(ligne_listes, 9).Value <> "")
Sheets("construction").Cells(ligne_listes, 9).Value = ""
Sheets("construction").Cells(ligne_listes, 10).Value = ""
Sheets("construction").Cells(ligne_listes, 11).Value = ""
Sheets("construction").Cells(ligne_listes, 12).Value = ""
Sheets("construction").Cells(ligne_listes, 13).Value = ""
Sheets("construction").Cells(ligne_listes, 14).Value = ""
Sheets("construction").Cells(ligne_listes, 15).Value = ""
Sheets("construction").Cells(ligne_listes, 16).Value = ""
Sheets("construction").Cells(ligne_listes, 17).Value = ""
Sheets("construction").Cells(ligne_listes, 18).Value = ""
Sheets("construction").Cells(ligne_listes, 19).Value = ""
Sheets("construction").Cells(ligne_listes, 20).Value = ""
Sheets("construction").Cells(ligne_listes, 21).Value = ""
Sheets("construction").Cells(ligne_listes, 22).Value = ""
Sheets("construction").Cells(ligne_listes, 23).Value = ""
Sheets("construction").Cells(ligne_listes, 24).Value = ""
Sheets("construction").Cells(ligne_listes, 25).Value = ""
ligne_listes = ligne_listes + 1
Wend

'parcours de la BDD pour identifier les numeros de lignes correspondant au cas ou il y a une correspondance
ligne_bd = 2
ligne_listes = 10
Sheets("Home").Select
While (Sheets("Database").Cells(ligne_bd, 1).Value <> "")
'extraction des lignes dans le cas ou il y a seulement I6 (producteur) de défini
    If (Range("I6").Value <> "" And Range("J6").Value = "" And Range("K6").Value = "") Then
        If (Sheets("Database").Cells(ligne_bd, 2).Value = Range("I6").Value) Then
        extraction ligne_listes, ligne_bd
        ligne_listes = ligne_listes + 1
        End If
'extraction des lignes dans le cas ou il y a I6 (producteur) et J6 (type de produit) de défini
    ElseIf (Range("I6").Value <> "" And Range("J6").Value <> "" And Range("K6").Value = "") Then
        If (Sheets("Database").Cells(ligne_bd, 2).Value = Range("J6").Value And Sheets("Database").Cells(ligne_bd, 3).Value = Range("J6").Value) Then
        extraction ligne_listes, ligne_bd
        ligne_listes = ligne_listes + 1
        End If
'extraction des lignes dans le cas ou il y a I6 (producteur) et K6 (Référence) de défini
    ElseIf (Range("J6").Value <> "" And Range("J6").Value = "" And Range("K6").Value <> "") Then
        If (Sheets("Database").Cells(ligne_bd, 2).Value = Range("J6").Value And Sheets("Database").Cells(ligne_bd, 4).Value = Range("K6").Value) Then
        extraction ligne_listes, ligne_bd
        ligne_listes = ligne_listes + 1
        End If
'extraction de la ligne dans le cas ou il y a I6 (producteur), J6 (type de produit) et K6 (référence) de défini
    ElseIf (Range("J6").Value <> "" And Range("J6").Value <> "" And Range("K6").Value <> "") Then
        If (Sheets("Database").Cells(ligne_bd, 2).Value = Range("J6").Value And Sheets("Database").Cells(ligne_bd, 3).Value = Range("J6").Value And Sheets("Database").Cells(ligne_bd, 4).Value = Range("K6").Value) Then
        extraction ligne_listes, ligne_bd
        ligne_listes = ligne_listes + 1
        End If
    End If
ligne_bd = ligne_bd + 1
Wend

End Sub

A chaque ligne qui correspond aux critères, cela fait appel a une macro "extraction" qui se charge de reporter les valeurs de la ligne dans la BDD sur la feuille Database dans la feuille construction, de la colonne I à Y, a partir de la ligne 10.

Voici le code qui je pense parraitrait très lourd et pas subtil du tout a certain O:-)

Sub extraction(ligne_listes As Integer, ligne_bd As Integer)

Sheets("construction").Cells(ligne_listes, 9).Value = Sheets("Database").Cells(ligne_bd, 1).Value
Sheets("construction").Cells(ligne_listes, 10).Value = Sheets("Database").Cells(ligne_bd, 2).Value
Sheets("construction").Cells(ligne_listes, 11).Value = Sheets("Database").Cells(ligne_bd, 3).Value
Sheets("construction").Cells(ligne_listes, 12).Value = Sheets("Database").Cells(ligne_bd, 4).Value
Sheets("construction").Cells(ligne_listes, 13).Value = Sheets("Database").Cells(ligne_bd, 5).Value
Sheets("construction").Cells(ligne_listes, 14).Value = Sheets("Database").Cells(ligne_bd, 6).Value
Sheets("construction").Cells(ligne_listes, 15).Value = Sheets("Database").Cells(ligne_bd, 7).Value
Sheets("construction").Cells(ligne_listes, 16).Value = Sheets("Database").Cells(ligne_bd, 8).Value
Sheets("construction").Cells(ligne_listes, 17).Value = Sheets("Database").Cells(ligne_bd, 9).Value
Sheets("construction").Cells(ligne_listes, 18).Value = Sheets("Database").Cells(ligne_bd, 10).Value
Sheets("construction").Cells(ligne_listes, 19).Value = Sheets("Database").Cells(ligne_bd, 11).Value
Sheets("construction").Cells(ligne_listes, 20).Value = Sheets("Database").Cells(ligne_bd, 12).Value
Sheets("construction").Cells(ligne_listes, 21).Value = Sheets("Database").Cells(ligne_bd, 13).Value
Sheets("construction").Cells(ligne_listes, 22).Value = Sheets("Database").Cells(ligne_bd, 14).Value
Sheets("construction").Cells(ligne_listes, 23).Value = Sheets("Database").Cells(ligne_bd, 15).Value
Sheets("construction").Cells(ligne_listes, 24).Value = Sheets("Database").Cells(ligne_bd, 16).Value
Sheets("construction").Cells(ligne_listes, 25).Value = Sheets("Database").Cells(ligne_bd, 17).Value

End Sub

Pour être honnête, je ne vois pas ce qui cloche, mais en tout cas, je n'au rien qui s'affiche de la colonne I à Y, à partir de la ligne 10 sur la feuille construction.

Pourriez-vous m'aider à identifier mon erreur et à la solutionner svp?

Je vous remercie par avance

Bastien

ps1 : J'ai initialement choisit des listes déroulantes en activex mais de plus en plus je pense a les remplacer éventuellement par des listes déroulantes en validation de données basée sur les listes définir dans la feuille construction, car j'ai des problèmes de redimensionnement automatique de la liste a l'ouverture du fichier Excel et à l'usage de la liste. J'ai beau les redimensionner en mode création, quand je ressors du mode création ou si je ferme en enregistrant et que j'ouvre à nouveau le fichier, la liste est redimensionné. Si vous avez une solution, merci par avance, mais bon ce n'est pas le sujet principal de ce post ;-).

ps2 : juste pour mentionné, j'ai dû désactiver des bouts du code pour générer les listes dans la feuille construction, car y avait un bug dans la récupération des infos à cause du fait que les noms de mes références ou les types de produits ont des chaines de caractères en commun ce qui faisait que certain type de produit ou référence n'était pas récupéré. Je ferais un second post spécifique à ce problème par la suite, pour le moment, j'ai contourné le problème en désactivant certaines lignes de code et appliquant une suppression des doublons sur la liste générée. J'ai reproduit dans le fichié joint ce "phénomène" en donna tdes nom de produit tel que T1, T2 et T1/T2. Si vous activez le code desactivé, par exemple, si on sélectionne C2 pour producteur on n'aura que T1/T2 et T2 comme type de produit proposé.

Bonjour,

Vous devriez écrire un livre parce que votre commentaire est pas loin du record de longueur .

Honnêtement, je n'ai pas vraiment fait attention au problème mais j'ai retouché le code pour qu'il soit plus lisible :

Sub extraire()

Dim ligne_listes As Integer
Dim ligne_bd As Integer

If application.countblank(Range("I6:K6")) = 3 Then Exit Sub

'efface les donnée récupérées précédement
ligne_listes = 10
While Sheets("construction").Cells(ligne_listes, 9).Value <> ""
    Sheets("construction").Range("I" & ligne_listes & ":Y" & ligne_listes).Value = ""
    ligne_listes = ligne_listes + 1
Wend

'parcours de la BDD pour identifier les numeros de lignes correspondant au cas ou il y a une correspondance
ligne_bd = 2
ligne_listes = 10
With Sheets("Home")
    While Sheets("Database").Cells(ligne_bd, 1).Value <> ""
'extraction des lignes dans le cas ou il y a seulement I6 (producteur) de défini
        If application.countblank(.Range("I6:K6")) = 2 Then
            if .Range("I6").value <> "" then 'pas sûr que cette condition soit nécessaire car I6 rempli en prio ?
                If Sheets("Database").Cells(ligne_bd, 2).Value = .Range("I6").Value Then
                    extraction ligne_listes, ligne_bd
                    ligne_listes = ligne_listes + 1
                End If
            end if
'extraction des lignes dans le cas ou il y a I6 (producteur) et J6 (type de produit) de défini
        ElseIf application.countblank(.Range("I6:K6")) = 1 then
            if .Range("K6").Value = "" Then
                If Sheets("Database").Cells(ligne_bd, 2).Value = .Range("J6").Value _
                And Sheets("Database").Cells(ligne_bd, 3).Value = .Range("J6").Value Then
                    extraction ligne_listes, ligne_bd
                    ligne_listes = ligne_listes + 1
                End If
'extraction des lignes dans le cas ou il y a I6 (producteur) et K6 (Référence) de défini
            ElseIf .Range("J6").Value = "" Then
                If Sheets("Database").Cells(ligne_bd, 2).Value = .Range("J6").Value _
                And Sheets("Database").Cells(ligne_bd, 4).Value = .Range("K6").Value Then
                    extraction ligne_listes, ligne_bd
                    ligne_listes = ligne_listes + 1
                End If
            end if
'extraction de la ligne dans le cas ou il y a I6 (producteur), J6 (type de produit) et K6 (référence) de défini
        ElseIf application.countblank(.Range("I6:K6")) = 0 Then
            If Sheets("Database").Cells(ligne_bd, 2).Value = .Range("J6").Value _
            And Sheets("Database").Cells(ligne_bd, 3).Value = .Range("J6").Value _
            And Sheets("Database").Cells(ligne_bd, 4).Value = .Range("K6").Value Then
                extraction ligne_listes, ligne_bd
                ligne_listes = ligne_listes + 1
            End If
        End If
    ligne_bd = ligne_bd + 1
    Wend
end with

End Sub

Et l'autre :

Sub extraction(ligne_listes As Integer, ligne_bd As Integer)

Dim wsCons as worksheet, wsData as worksheet

Set wsCons = Sheets("construction") 'pas nécessaire mais pour avoir l'instruction sur une seule ligne
Set wsData = Sheets("Database")

wsCons.Range("I" & ligne_listes & ":Y" & ligne_listes).Value = wsData.Cells("A" & ligne_bd & ":Q" & ligne_bd).Value

Set wsCons = Nothing
Set wsData = Nothing

End Sub

Cdlt,

Hello

Désolé pour ce post super long , je l'admet, mais je vouslais etre sur de bien expliquer ma problematique

Merci beaucoup pour ton aide et pour les simplication que tu as réaliser dans mon code, cela m'a aider a identifier ce qui empechait le code de fonctionner correctement.

Maintenant ça marche bien :-)

Voici le code que ça donne. J'ai laissé les morceaux de code que j'ai deactiver pour le suivi d'évolution.

Sub extraire()

Dim ligne_listes As Integer
Dim ligne_bd As Integer

'If Application.CountBlank(Range("I6:K6")) = 3 Then Exit Sub

'efface les donnée récupérées précédement
ligne_listes = 10
While Sheets("construction").Cells(ligne_listes, 9).Value <> ""
    Sheets("construction").Range("I" & ligne_listes & ":Y" & ligne_listes).ClearContents
    ligne_listes = ligne_listes + 1
Wend

'parcours de la BDD (Database) pour identifier les numeros de lignes correspondant au cas ou il y a une correspondance
ligne_bd = 2
ligne_listes = 10
With Sheets("construction")
    While (Sheets("Database").Cells(ligne_bd, 1).Value <> "")
'extraction des lignes dans le cas ou il y a seulement I6 (producteur) de défini
        If Application.CountBlank(.Range("I6:K6")) = 2 Then
            'If .Range("I6").Value <> "" Then
                If Sheets("Database").Cells(ligne_bd, 2).Value = .Range("I6").Value Then
                    extraction ligne_listes, ligne_bd
                    ligne_listes = ligne_listes + 1
                End If
            'End If
'extraction des lignes dans le cas ou il y a I6 (producteur) et J6 (type de produit) de défini
        ElseIf Application.CountBlank(.Range("I6:K6")) = 1 Then
            'If .Range("K6").Value = "" Then
                If Sheets("Database").Cells(ligne_bd, 2).Value = .Range("I6").Value _
                And Sheets("Database").Cells(ligne_bd, 3).Value = .Range("J6").Value Then
                    extraction ligne_listes, ligne_bd
                    ligne_listes = ligne_listes + 1
                'End If
'extraction des lignes dans le cas ou il y a I6 (producteur) et K6 (Référence) de défini
            'ElseIf .Range("J6").Value = "" Then
                ElseIf Sheets("Database").Cells(ligne_bd, 2).Value = .Range("I6").Value _
                And Sheets("Database").Cells(ligne_bd, 4).Value = .Range("K6").Value Then
                    extraction ligne_listes, ligne_bd
                    ligne_listes = ligne_listes + 1
                End If
            'End If
'extraction de la ligne dans le cas ou il y a I6 (producteur), J6 (type de produit) et K6 (référence) de défini
        ElseIf Application.CountBlank(.Range("I6:K6")) = 0 Then
            If Sheets("Database").Cells(ligne_bd, 2).Value = .Range("I6").Value _
            And Sheets("Database").Cells(ligne_bd, 3).Value = .Range("J6").Value _
            And Sheets("Database").Cells(ligne_bd, 4).Value = .Range("K6").Value Then
                extraction ligne_listes, ligne_bd
                ligne_listes = ligne_listes + 1
            End If
        End If
    ligne_bd = ligne_bd + 1
    Wend
End With

End Sub

Sub extraction(ligne_listes As Integer, ligne_bd As Integer)

Dim wsCons As Worksheet, wsData As Worksheet

Set wsCons = Sheets("construction")
Set wsData = Sheets("Database")

wsCons.Range("I" & ligne_listes & ":Y" & ligne_listes).Value = wsData.Range("A" & ligne_bd & ":Q" & ligne_bd).Value

Set wsCons = Nothing
Set wsData = Nothing

End Sub

Et le problème est résolu alors ? C'est un miracle !