Lister valeurs unique d'une bdd en VBA

Bonsoir,

Je travaille régulièrement avec un fichier Excel qui comporte une liste d'articles (des cylindres de serrures) avec des quantités/types/dimensions/Nb de clé différents.

Je dois très souvent "résumer" ces tableaux/listes dans un mail et en les regroupant par type de cylindre et dimensions identiques.

Quand le tableau est petit, j'utilise les filtres et je le fais à la mano.

Quand le tableau est plus important, j'utilise un TCD.

Mais comme je souhaite apprendre le VBA, je voudrais essayer de faire cette action répétitive et parfois fastidieuse via un code VBA (et non des formules).

Voici un fichier qui résume ce que j'ai et ce que je veux :

En gros je souhaite un résultat de la forme :

W pièce(s) du type de cylindre A en dimensions L1xL1

X pièce(s) du type de cylindre A en dimensions L2xL2

Y pièce(s) du type de cylindre B en dimensions L1xL1

Z pièce(s) de clés au total

Merci d'avance pour votre aide,

Vip4rk

Bonjour

Une solution PowerQuery (intégré à 2016)

Mise à jour par Données, Actualiser tout

Bonsoir @78chris,

Merci pour ton aide, c'est effectivement une solution intéressante.

D'autant que j'ai souvent entendu parler de PowerQuery sans jamais encore l'avoir utilisé.

Je vais la potasser par curiosité intellectuelle.

Toutefois je suis quand même preneur d'un code vba faisant la même chose

Vip4rk

Bonjour,

Avec une fonction personnalisée

Boisgontier

Hello @Boisgontierjacques

Merci pour l'aide mais je sais déjà le faire avec des formules et je cherche plutôt un code VBA pour me permettre d'aller encore plus loin dans l'optimisation de ce que je pourrai faire (car ça sera encore un peu plus complexe que ce que j'ai énoncé).

De plus mon objectif est vraiment de progresser en VBA.

Mais je vais déjà essayer de produire un bout de code moi-même et je vous le soumettrai par la suite.

Vip4rk

>je cherche plutôt un code VBA

Une fonction personnalisée est écrite en VBA.

Elle a l'avantage d'être réutilisable.

Boisgontier

@Boisgontierjacques

Oui c'est vrai

Vip4rk

Pour l'instant j'arrive déjà à trouver la liste des types de cylindres différents et à l'écrire dans un nouvel onglet.

Option Explicit
'
Sub Article_List()
'
Application.ScreenUpdating = False
'
Dim MonDico
Dim Table_Unique_Article
Dim i As Long
'
'Je définis les valeurs unique des types d'articles (cylindres) en colonne H
Set MonDico = CreateObject("Scripting.Dictionary")
Table_Unique_Article = Worksheets("Plan").Range("H17:H" & [H65000].End(xlUp).Row)
    For i = LBound(Table_Unique_Article) To UBound(Table_Unique_Article)
    MonDico(Table_Unique_Article(i, 1)) = ""
    Next i
'
'Je créé un nouvel onglet
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Article_List"
'Je colle le résultat dans ce nouvel onglet
Worksheets("Article_List").Range("A1").Resize(MonDico.Count, 1) = Application.Transpose(MonDico.keys)
'
Application.ScreenUpdating = False
'
End Sub

Step 2 : j'essaye d'intégrer le deuxième paramètre à prendre en compte dans ma liste d'articles : les dimensions des cylindres.

Pas simple!

Vip4rk

Sous forme de SUB

Option Compare Text

Sub compte()
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = vbTextCompare
  temp = [B4:D10].Value
  nbCol = UBound(temp, 2)
  For i = 1 To UBound(temp)
    tmp = ""
    For k = 1 To nbCol
       tmp = tmp & temp(i, k) & "|"
    Next k
    If temp(i, 1) <> "" Then d(tmp) = d(tmp) + 1
  Next i
  ReDim b(1 To d.Count, 1 To nbCol + 1)
  i = 0
  For Each c In d.keys
    i = i + 1
    a = Split(c, "|")
    For k = 1 To nbCol
      b(i, k) = a(k - 1)
    Next k
    b(i, k) = d(c)
  Next
  [G4].Resize(d.Count, nbCol + 1) = b
End Sub

Boisgontier

Merci Boisgonthier pour ta réponse.

J'ai bien regardé ton code et c'est intéressant.

Mais entre temps j'ai aussi pas mal avancé sur le mien :

Option Explicit
'
Sub Article_List()
'
Application.ScreenUpdating = False
'
Dim d
Dim Table_Keyplan
Dim i As Long
Dim clé
Dim lig
'
'Je définis les valeurs unique des types d'articles (cylindres) en colonne H
Set d = CreateObject("Scripting.Dictionary")
Table_Keyplan = Worksheets("Plan").Range("H17:M" & [M65000].End(xlUp).Row)
'
Dim Table_Article_List(): ReDim Table_Article_List(1 To UBound(Table_Keyplan), 1 To UBound(Table_Keyplan))
'
    For i = LBound(Table_Keyplan) To UBound(Table_Keyplan)
    '
    clé = Table_Keyplan(i, 1) & "|" & Table_Keyplan(i, 6)    ' Clé multi-colonnes
    '
    If d.exists(clé) Then
        lig = d(clé)             ' Récupération index Table_Article_List()
    Else
        d(clé) = d.Count + 1: lig = d.Count: Table_Article_List(lig, 1) = Table_Keyplan(i, 1): Table_Article_List(lig, 2) = Table_Keyplan(i, 6)   ' Nouvelle clé
    End If
'
    Next i
'
'Je créé un nouvel onglet
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Article_List"
'Je colle le résultat dans ce nouvel onglet
Worksheets("Article_List").Range("A1").Resize(d.Count, UBound(Table_Article_List)) = Table_Article_List
'
Application.ScreenUpdating = True
'
End Sub

Le résultat est pas mal : j'obtiens bien la liste de type de cylindre unique par dimensions extérieures unique.

Step 3 : intégrer le 3ème critère, la dimension intérieure...

J'avance pas à pas!

Vip4rk

Pour info voici mon fichier de travail :

Vip4rk

J'ai bien réussi l'étape 3 (oui je spam et oui je me réponds tout seul mais c'est au cas ou quelqu'un essaye de m'aider pour ne pas lui faire perdre son temps).

Step 4 : je dois sommer les quantités d’occurrences identiques en sommant les quantités inscrites en colonne G.

Vip4rk

Ca y est je sèche.. Mon total de cylindre par type et dimensions ne s'affiche pas ou je veux!

Option Explicit
'
Sub Article_List()
'
Application.ScreenUpdating = False
'
Dim d
Dim Table_Keyplan
Dim i As Long
Dim clé
Dim lig
Dim c
'
Set d = CreateObject("Scripting.Dictionary")
Table_Keyplan = Worksheets("Plan").Range("G17:N" & [N65000].End(xlUp).Row)
'
Dim Table_Article_List(): ReDim Table_Article_List(1 To UBound(Table_Keyplan), 1 To UBound(Table_Keyplan))
'
    For i = LBound(Table_Keyplan) To UBound(Table_Keyplan)
    '
    clé = Table_Keyplan(i, 2) & "|" & Table_Keyplan(i, 6) & "|" & Table_Keyplan(i, 7)    ' Clé multi-colonnes
    '
    If d.exists(clé) Then
        lig = d(clé)             ' Récupération index Table_Article_List()
    Else
        d(clé) = d.Count + 1: lig = d.Count: Table_Article_List(lig, 1) = Table_Keyplan(i, 2): Table_Article_List(lig, 2) = Table_Keyplan(i, 6): Table_Article_List(lig, 3) = Table_Keyplan(i, 7)   ' Nouvelle clé
    End If
'
    For c = 1 To UBound(Table_Keyplan): Table_Article_List(lig, c) = Table_Article_List(lig, c) + Table_Keyplan(i, c): Next c   ' On somme les qté de cylindres par type et dimensions uniques
'
    Next i
'
'Je crée un nouvel onglet
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Article_List"
'Je colle le résultat dans ce nouvel onglet
Worksheets("Article_List").Range("A1").Resize(d.Count, UBound(Table_Article_List)) = Table_Article_List
'
Application.ScreenUpdating = True
'
End Sub

Le fichier :

Vip4rk

J'ai réussi

Pour info si un jour ça intéresse qqun :

Option Explicit
'
Sub Article_List()
'
Application.ScreenUpdating = False
'
Dim d
Dim Table_Keyplan
Dim i As Long
Dim clé
Dim lig
Dim c As Long
'
Set d = CreateObject("Scripting.Dictionary")
Table_Keyplan = Worksheets("Plan").Range("G17:N" & [N65000].End(xlUp).Row)
'
Dim Table_Article_List(): ReDim Table_Article_List(1 To UBound(Table_Keyplan), 1 To UBound(Table_Keyplan, 2))
'
    For i = LBound(Table_Keyplan) To UBound(Table_Keyplan)
    '
    clé = Table_Keyplan(i, 2) & "|" & Table_Keyplan(i, 6) & "|" & Table_Keyplan(i, 7)    ' Clé multi-colonnes
    '
    If d.exists(clé) Then
        lig = d(clé)             ' Récupération index Table_Article_List()
    Else
        d(clé) = d.Count + 1: lig = d.Count: Table_Article_List(lig, 1) = Table_Keyplan(i, 2): Table_Article_List(lig, 2) = Table_Keyplan(i, 6): Table_Article_List(lig, 3) = Table_Keyplan(i, 7) ' Nouvelle clé
    End If
'
    Table_Article_List(lig, 4) = Table_Article_List(lig, 4) + Table_Keyplan(i, 1)  ' On somme les qté de cylindres par type et dimensions uniques
'
    Next i
'
Range("A22").Resize(d.Count, UBound(Table_Article_List)) = Table_Article_List
'
Application.ScreenUpdating = True
'
End Sub

Vip4rk