Classer des données suivant un "arbre" (VBA)

[Spacepak]

Bonjour,

J'aimerai créer une macro en VBA pour récupérer et afficher les données suivant un modèle d'arbre.

Je m'explique :

Dans mon fichier il y a 3 onglets:
- le 1 er est la page d'affichage. Quand on entre un client (exemple Client A) dans la barre de recherche, on doit afficher et classer toutes les données qui lui sont rattachées à savoir le panier d'articles, puis pour chaque panier, tous les articles qui lui sont rattachés, puis pour chaque article, toutes les dates d'achat ainsi que de nouvelles infos qui sont propres à l'article.

J'ai bien détaillé l'exemple dans mon fichier excel.

- le deuxième onglet représente une sorte de base ou on voit toutes les caractéristiques des articles ( dans quel panier ils sont attachés, quel client et d'autres infos "info 1", "info 2", etc...

- le 3 ème onglet représente tous les achats.


J'avoue que ça me parait bien ambitieux comme projet mais malgré mes essais, je ne parviens pas à faire exactement ce que je veux.

Pourriez-vous m'aider svp?

N’hésitez pas à me demander plus d'infos si mon explication n'est pas claire.

Je vous remercie.

Cordialement

 

[Dranreb]

Bonjour.
C'est probablement du travail pour ma fonction Gigogne.

Mais dans la meilleure feuille candidate comme source de données, on n'y trouve pas l'information du panier, alors…

 

[Spacepak]

Bonjour Dranreb,

Je vous remercie pour votre aide.

Mais euh... comment ça marche?

J'ai lu un peu l'aide mais je ne comprend pas trop comment je pourrai exploiter ce code.

 

[Dranreb]

Il permet de grouper des données dans une collection pouvant contenir des collections de … collections de collections, organisées comme un arbre et qui s'explore par des For Each In imbriqués pour constituer un rapport de tout ce qu'il y a.

 

[klin89]

Bonjour Spacepak, Dranreb

Si l'on suit ton raisonnement, il manque cette ligne

dans le résultat affiché

Ne manque t-il pas la colonne client dans la feuille "Achats" ?

klin89

 

[Spacepak]

Il permet de grouper des données dans une collection pouvant contenir des collections de … collections de collections, organisées comme un arbre et qui s'explore par des For Each In imbriqués pour constituer un rapport de tout ce qu'il y a.

Ok j'ai donc de la lecture à faire!
Je vous remercie pour l'aide.

 

[Spacepak]

Bonjour Spacepak, Dranreb


Ne manque t-il pas la colonne client dans la feuille "Achats" ?

klin89

Bonjour klin89,

Non pas besoin de "Client" Dans "Achats" par contre, il y a un oubli dans l'onglet "Articles".
En fait la colonne "Code" devient " Code Article" pour correspondre avec l'onglet Achats.

Ce qui permet de faire le lien entre les deux onglets.

Je sais pas si je suis clair :S

 

[klin89]

Re Spacepak,

Je persiste :

Dans la feuille "Achats", figurent 2 lignes -Table-
A quel client doit-on attribuer la ligne du 15/12/2015

klin89

 

[Spacepak]

Bon j'avoue, il y a une erreur

Il faut rajouter cette ligne dans la page "Résultat" pour le client A!

Tadaaa

 

[klin89]

Re Spacepak

A tester, restitution en feuille "Résultats"

Option Explicit
Option Compare Text
Sub test()
Dim a, w(), e, v, i As Long, j As Long, n As Long
Dim dico As Object, client As String
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Résultats")
        client = .Cells(1, 2).Value
        .UsedRange.Offset(6).Cells.Clear
    End With
    With Sheets("Articles").Range("a1").CurrentRegion
        If WorksheetFunction.CountIf(.Columns(3), client) = 0 Then _
           MsgBox "client inexistant": Exit Sub
        a = .Value
    End With
    For i = 2 To UBound(a, 1)
        If a(i, 3) = client Then
            If Not dico.exists(a(i, 4)) Then
                Set dico(a(i, 4)) = CreateObject("Scripting.Dictionary")
                dico(a(i, 4)).CompareMode = 1
            End If
            If Not dico(a(i, 4)).exists(a(i, 2)) Then
                ReDim w(1 To 7, 1 To 1)
                w(1, 1) = a(i, 1): w(2, 1) = a(i, 2)
                For j = 5 To UBound(a, 2)
                    w(j - 2, 1) = a(i, j)
                Next
                dico(a(i, 4))(a(i, 2)) = w
            End If
        End If
    Next
    a = Sheets("Achats").Range("a1").CurrentRegion.Value2
    For Each e In dico.keys
        For i = 2 To UBound(a, 1)
            If dico(e).exists(a(i, 3)) Then
                w = dico(e)(a(i, 3))
                If UBound(w, 2) = 1 Then
                    ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 2)
                    w(2, UBound(w, 2) - 1) = a(1, 1)
                    For j = 4 To UBound(a, 2)
                        w(j - 1, UBound(w, 2) - 1) = a(1, j)
                    Next
                Else
                    ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
                End If
                w(2, UBound(w, 2)) = a(i, 1)
                For j = 4 To UBound(a, 2)
                    w(j - 1, UBound(w, 2)) = a(i, j)
                Next
                dico(e)(a(i, 3)) = w
            End If
        Next
    Next
    For Each e In dico.keys
        For Each v In dico(e).keys
            If UBound(dico(e)(v), 2) = 1 Then dico(e).Remove v
        Next
    Next
    For Each e In dico.keys
        If dico(e).Count = 0 Then dico.Remove e
    Next
    Application.ScreenUpdating = False
    If dico.Count > 0 Then
        'Restitution et mise en forme
        With Sheets("Résultats").Cells(1)
            n = 6
            For i = 0 To dico.Count - 1
                .Offset(n, 1).Value = dico.keys()(i)
                For j = 0 To dico.items()(i).Count - 1
                    With .Offset(n, 2).Resize(UBound(dico.items()(i).items()(j), 2), UBound(dico.items()(i).items()(j), 1))
                        With .Offset(2, 1).Resize(.Rows.Count - 2)
                            .Columns(1).NumberFormat = "dd/mm/yyyy;@"
                            .Columns(3).NumberFormat = "#,##0.00 $"
                        End With
                        .Value = Application.Transpose(dico.items()(i).items()(j))
                        With .CurrentRegion.Rows(1)
                            .Cells(1).Resize(, 2).Font.Bold = True
                            .BorderAround Weight:=xlThin
                            .Borders(xlInsideVertical).Weight = xlThin
                        End With
                        With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 2)
                            .BorderAround Weight:=xlThin
                            .Borders(xlInsideVertical).Weight = xlThin
                            .Borders(xlInsideHorizontal).Weight = xlThin
                            .Rows(1).Font.Bold = True
                            With .Font
                                .Size = 8
                                .Italic = True
                            End With
                        End With
                    End With
                    n = n + UBound(dico.items()(i).items()(j), 2) + 1
                Next
            Next
            With .Parent.UsedRange.Offset(6).Cells
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
        End With
    Else
        MsgBox "aucun achat effectué par " & client
    End If
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

 

[Spacepak]

Salut Klin89,

Merci beaucoup pour ton code!

Tout marche nikel!

Créer un dico de dicos, je ne savais pas comment m'y prendre..

 

[Spacepak]

J'ai juste une question

Pourriez-vous juste m'expliquer ce bout de code svp?


If Not dico.Exists(a(i, 4)) Then '
Set dico(a(i, 4)) = CreateObject("Scripting.Dictionary")
End If
If Not dico(a(i, 4)).Exists(a(i, 2)) Then
ReDim w(1 To 13, 1 To 1)
End If
w(1, 1) = a(i, 1): w(2, 1) = a(i, 2)
For j = 5 To UBound(a, 2)
w(j - 2, 1) = a(i, j)
Next


Dans la première ligne, on regarde si la clé (a(i,4) qui se réfère à "Campagne.." a une valeur.
Si ce n'est pas le cas, on crée un nouveau dico qui a pour nom dico(a(i,4)) ?
Ensuite on regarde si la clé (a(i,2)) de ce nouveau dico a une valeur etc?

 

[Dranreb]

Bonjour.
Remarque: si les données sont à prendre de plusieurs feuilles, il est tout à fait possible d'utiliser les fonctionnalité de concaténation de tableaux de GigIdx pour définir les données pour la fonction Gigogne.

 

[Spacepak]

Bonjour Dranreb,

Je vais tester votre fonction également.
Merci à vous pour votre aide!

(à chaque fois je lis "fonction cygogne" hum)

 

[Dranreb]

Bonjour.
La programmation avec le complément, résultat à partir de la ligne 29.