Remplir dictionnary avec array

Le 16/07/2021 à 15:43

Bonjour,

J'ai un array qui est généré par un code que je souhaite ordonner, enlever les doublons tout en réalisant un comptage.

On m'a suggéré d'utiliser un dictionnaire pour réaliser ce tri ce qui marche parfaitement avec des cellules données. Mais je souhaite bien transposer mon array directement dans le dictionnaire, et ici ca cloche un peu. Si quelqu'un peut m'aiguiller ca serait top

J'ai simplifié le problème que je rencontre avec l'excel joint et le code qui suit :

Code sans passer par l'array

Sub CompteItems()

Dim tabtube(8, 0)

For i = 1 To 8

tabtube(i - 1, 0) = Cells(i + 1, 1)

Next i

'Range("B2", "B10") = tabtube

  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico(c.Value) = mondico(c.Value) + 1
  Next c
  [C2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [d2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
  [C1].Sort Key1:=[C2], Order1:=xlAscending, Header:=xlYes
End Sub

En passant par l'array

Sub CompteItems2()
Set mondico = CreateObject("Scripting.Dictionary")
With ActiveSheet
    tabtube = .Range("A2:A9").Value
   ' .Range("B2", "B9") = tabtube
    For Each c In tabtube
       mondico(c.Value) = mondico(c.Value) + 1
    Next c
    .[C2].Resize(mondico.Count, 2) = Application.Transpose(Array(mondico.keys, mondico.items))
    .[C1].Sort Key1:=.[C2], Order1:=xlAscending, Header:=xlYes
End With
End Sub

Merci pour votre aide

Je vous joints le fichier simplifié "try" avec mes essaies dans le module_2 et aussi mon fichier complet "confpartage_v4" ou la réalisation de ce dico est dans la partie M03_LongCannes

17confpartage-v4.xlsm (174.81 Ko)
12try.xlsm (18.10 Ko)
Le 16/07/2021 à 17:38

Salut BARNS,

Désolé, je me suis mal exprimé sur l'autre sujet. En fait, j'ai modifié le code pour y enlever la propriété .value :

https://forum.excel-pratique.com/excel/regrouper-valeurs-array-159804#p990574

Sub CompteItems()
Set mondico = CreateObject("Scripting.Dictionary")
with activesheet
    tabtube = .range("A2:A9").value
    For Each c in tabtube
        mondico(c) = mondico(c) + 1
    Next c
    .[C2].Resize(mondico.Count, 2) = Application.Transpose(array(mondico.keys, mondico.items))
    .[C1].Sort Key1:=.[C2], Order1:=xlAscending, Header:=xlYes
end with
End Sub

Ce code devrait fonctionner en principe.

Cdlt,

Le 16/07/2021 à 17:39

Salut

tu veux dire comme ça :

Sub test()

  Set mondico = CreateObject("Scripting.Dictionary")
  tbl = Range("a2:a" & [a65000].End(xlUp).Row)
  For i = LBound(tbl) To UBound(tbl)
    mondico(tbl(i, 1)) = ""
  Next i
  [c2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [c2].Sort Key1:=[c2], Order1:=xlAscending, Header:=xlYes
End Sub

EDIT: Salut 3GB sur la même instant

Le 20/07/2021 à 18:30

Bonjour,

Merci beaucoup pour vos réponses. Bon il semblerait que vous maitrisez l'outil dictionnaire donc je profite de poser une petite question sur mon bout de programme qui ne marche pas qui est aussi avec un dictionnaire.

Je souhaite réalisé un regroupement de valeur sans doublons mais ici j'ai plusieurs colonnes.

Du coup sur un fichier d'essai simple cela marche à merveille (cf try)

Sub RegroupeSousTotall()

Set d1 = CreateObject("Scripting.Dictionary")

Set f1 = Sheets("user")

tbl = f1.Range("A2:C" & f1.[A65000].End(xlUp).Row).Value

Ncol = 3

Dim TblRes(): ReDim TblRes(1 To UBound(tbl), 1 To Ncol)

For ligne = 1 To UBound(tbl)

clé = tbl(ligne, 2)

If d1.exists(clé) Then

lig = d1(clé)

Else

d1(clé) = d1.Count + 1: lig = d1.Count ' index

For k = 2 To 3: TblRes(lig, k) = tbl(ligne, k): Next k

End If

TblRes(lig, 1) = TblRes(lig, 1) + tbl(ligne, 1)

Next ligne

Set f1 = Sheets("User")

derniereL = f1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row: derniereL = derniereL + 5

f1.Cells(derniereL, 2).Resize(, Ncol).Copy f1.Cells(derniereL, 2)

f1.Cells(derniereL + 1, 2).Resize(d1.Count, Ncol) = TblRes

End Sub

Mais a partir du moment que je change le range par mon tableau, ca ne marche plus.

Je crois que

f1.Range("A2:C" & f1.[A65000].End(xlUp).Row).Value

est completement différent d'un array mais du coup je sais pas comment manipuler tout ca.

Dans mon fichier (cf confpartage) c'est dans le module M0_Materiel montage, sub regroupesous totall ()

Sub RegroupeSousTotall()

Set d1 = CreateObject("Scripting.Dictionary")

Set f1 = Sheets("user")

tbl = matmont

Ncol = 3

Dim TblRes(): ReDim TblRes(1 To UBound(tbl), 1 To Ncol)

For ligne = 1 To UBound(tbl)

clé = tbl(ligne, 2)

If d1.exists(clé) Then

lig = d1(clé)

Else

d1(clé) = d1.Count + 1: lig = d1.Count ' index

For k = 2 To 3: TblRes(lig, k) = tbl(ligne, k): Next k

End If

TblRes(lig, 1) = TblRes(lig, 1) + tbl(ligne, 1)

Next ligne

Set f1 = Sheets("User")

derniereL = f1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row: derniereL = derniereL + 15

f1.Cells(derniereL, 2).Resize(, Ncol).Copy f1.Cells(derniereL, 2)

f1.Cells(derniereL + 1, 2).Resize(d1.Count, Ncol) = TblRes

End Sub

Merci encore pour votre précieuse aide.

19confpartage-v7.xlsm (173.40 Ko)
10try.xlsm (17.30 Ko)
Le 20/07/2021 à 23:16

Bonjour BARNS, Salut AMIR,

Si je ne me trompe pas, le code est identique sauf à la ligne :

tbl = matmont

Qu'est-ce que matmont ? Une variable ?

En tout cas, ça ne semble pas être un problème lié au dictionnaire mais au tableau tbl et aux données qu'il contient.

Cdlt,

Le 21/07/2021 à 07:52

Bonjour,

Effectivement le code est identique sauf à ce point là.

Ce qui pose problème est que matmont soit un array et f1.Range("A2:C" & f1.[A65000].End(xlUp).Row).Value .

Je suppose que cette différence fait que le dictionnaire ne traite pas la variable de la même manière.

Quand je lance le code avec matmont j'ai une erreur au niveau de next k.

Le 21/07/2021 à 11:19

Bonjour,

Quel est le message d'erreur ? L'indice n'appartient pas à la sélection ?

Déjà, il vaut mieux changer cette ligne ainsi :

For k = 2 To 3
    TblRes(lig, k) = tbl(ligne, k)
Next k

Mais tant qu'on ne sait pas d'où vient matmont, c'est difficile de comprendre... J'imagine que matmont est un tableau à 1 ou 2 colonnes et non 3, ce qui expliquerait l'erreur.

Cdlt,

Le 21/07/2021 à 12:48

Bonjour,

Si ça peut t'aider moi j'ai travaillé sur la V20 mais ça marche pareil avec la V7 : Ya juste à changer la destination finale au lieu de M55 tu mets... ailleurs!

Je peux te donner ma version de Dico donc dédoublonné , après, c'est à toi de te débrouiller pour recenser les quantités qui vont bien avec...

Option Explicit
Sub Galopin()
Dim i%, z%, e%, n%, iLR%, S$, dico, WS As Worksheet
Dim matmont(10, 6), Arr() As String, Tablo
   Set WS = Worksheets("montage")
   Set dico = CreateObject("Scripting.Dictionary")
   With WS
       n = 0
           For z = 4 To 14 'jusqu'a la fin du tableau en colonne
               If Range("Choix_pos_regulateurs") = .Cells(1, z) Then Exit For
           Next z
           For e = 2 To 32
               If .Cells(e, z) >= 1 Then 'NE PAS AFFICHER SI PIQRAMPE OU PIQKITROUE =0
                  If .Cells(e, 1) <> "" Then
                     If Not dico.Exists(.Cells(e, 2) & "|" & .Cells(e, 3)) Then
                       dico(.Cells(e, 2) & "|" & .Cells(e, 3)) = ""
                     End If
                  End If
               End If
           Next e
   End With
   Tablo = dico.keys
                                   'Le dico est affiché en M55
   For i = 0 To dico.Count - 1
      S = Tablo(i)
      Arr = Split(S, "|")
      Range(Cells(55 + i, 13), Cells(55 + i, 14)) = Arr
   Next

   Arr = Range(Cells(55 + i, 13), Cells(55 + i, 15)).Value
   'A toi de jouer maintenant pour combler la 3ème colonne de ce nouvel Array
End Sub
Le 21/07/2021 à 16:41

Salut 3GB , galopin01 et BARNS

Je n ai pas encore compris, mais regarder ça :

10essai.xlsm (20.16 Ko)

Cette exemple surprime toute la ligne de doublon trouvés, parce que tu ne peux pas supprimer le doublon et garder son correspondance sur les autres colonnes :

Sub test()
Dim tmps
Set Dic = CreateObject("Scripting.Dictionary")

nbr_clns = 3 'nbre de colonnes de toute la plage ici A2 :C13
chx_d = 1 'choix de la colonne pour supprimer les doublons
chxFltr = 8 'choix de la colonne pour le filter iici h=8
drlgn = Cells(Rows.Count, chx_d).End(xlUp).Row
ReDim tmps(1 To nbr_clns, 1 To 1)
tbl = Range(Cells(2, "A"), Cells(drlgn, "C"))
For i = LBound(tbl, 1) To UBound(tbl, 1)
If Not (Dic.exists(tbl(i, chx_d))) Then 'vérification si la Clé n'est pas déjà présente dans le Dictionnaire
Dic(tbl(i, chx_d)) = tbl(i, chx_d)
n = n + 1
ReDim Preserve tmps(1 To nbr_clns, 1 To n)
For j = 1 To nbr_clns
tmps(j, n) = tbl(i, j)
Next
End If
Next i
Cells(2, chxFltr).Resize(n, nbr_clns) = _
Application.WorksheetFunction.Transpose(tmps) 'ici n=ubound(tmps,2)
Cells(2, chxFltr).Sort Key1:=Cells(2, chxFltr), Order1:=xlAscending, Header:=xlYes
End Sub

Ceci est autre exemple mais qui peut regroupe autre fonctionnalité :

Si tu veux garder l’info des doublons ou additionner leur infos tu peux choisir quand l'addition doit se faire avec : add_d= true

Tu peux choisir quand l'addition doit se faire comme somme de nbres ou comme une concaténation de chaine : Nmrc = true

Sub test02()
Dim tmps
Set Dic = CreateObject("Scripting.Dictionary")
nbr_clns = 3
chx_d = 1 'choix de la colonne pour supprimer les doublons
chx_add = 1 'choix de la colonne pour addition les info des doublons
chxFltr = 8 'choix de la colonne pour le filter iici h=8
add_d = True 'Tu peux choisir quand l'addition doit se faire avec : add_d= true
Nmrc = True 'Tu peux choisir quand l'addition doit se faire comme somme de nbres ou comme une concaténation de chaine : add_d= true
drlgn = Cells(Rows.Count, chx_d).End(xlUp).Row
ReDim tmps(1 To nbr_clns, 1 To 1)
tbl = Range(Cells(2, "A"), Cells(drlgn, "C"))
For i = LBound(tbl, 1) To UBound(tbl, 1)
If Not (Dic.exists(tbl(i, chx_d))) Then 'vérification si la Clé n'est pas déjà présente dans le Dictionnaire
n = n + 1
Dic.Add tbl(i, chx_d), n
ReDim Preserve tmps(1 To nbr_clns, 1 To n)
For j = 1 To nbr_clns
tmps(j, n) = tbl(i, j)
Next
Else
If add_d = True Then
lr = ", "
h = Dic.Item(tbl(i, chx_d))
If Nmrc = True Then lr = 0
If IsNumeric(tbl(i, chx_add)) Then
tmps(chx_add, h) = tmps(chx_add, h) + lr + tbl(i, chx_add)
Else
MsgBox "tu ne peux pas additionner des textes : les textes seront concaténés !"
lr = ", "
tmps(chx_add, h) = tmps(chx_add, h) + lr + tbl(i, chx_add)
End If
End If
End If
Next i
Cells(2, chxFltr).Resize(n, nbr_clns).ClearContents
Cells(2, chxFltr).Resize(n, nbr_clns) = _
Application.WorksheetFunction.Transpose(tmps) 'ici n=ubound(tmps,2)
Cells(2, chxFltr).Sort Key1:=Cells(2, chxFltr), Order1:=xlAscending, Header:=xlYes
End Sub
Le 21/07/2021 à 17:44

Salut tout le monde

J’ai modifié le classeur pour une meilleure performance ; Comme ça tu peux additionner les chiffres soit comme une somme ou comme une concaténation de textes.

Noter bien que chx_d ne doit pas égal a chx_add parce que c’est autre chose !

regarder ce dernier exemple :

15essai.xlsm (21.29 Ko)
Le 23/07/2021 à 11:41

AMIR,

J'ai regardé le fichier et quand je lance le code j'obtiens cela

image

Je devrais obtenir cela :

image

Après le code est bien expliqué alors je vais me mettre dedans pour comprendre ces histoires de dico !

Merci !

Le 23/07/2021 à 14:02

Salut

essayer de comprendre ça :

14trys.xlsm (24.26 Ko)
Le 23/07/2021 à 16:11

Je sais plus du tout ce que vous brocantez tous les 2 : ON est passé de la V20 à la V7 et maintenant à la version ABCD...

Je ne sais même pas si tu as lu ma réponse précédente...

Bon pour la V7 maintenant je te donne le regroupement de la zone B42:C50...

Sub Regroupe()
   Dim i%, S$, dico, WS As Worksheet, rng As Range, Arr
   Set WS = Worksheets("User")
   Set rng = WS.Range("B42").CurrentRegion
   Arr = rng.Value
   If rng.Count > 1 Then
      rng.ClearContents
      Set dico = CreateObject("Scripting.Dictionary")
   End If
   For i = 1 To UBound(Arr)
      S = Arr(i, 2) & "|" & Arr(i, 3)
         If Not dico.Exists(S) Then
            dico(S) = Arr(i, 1)
         Else
            dico(S) = dico(S) + Arr(i, 1)
         End If
   Next
   Tablo = dico.keys
   'Affiche les clefs
   For i = 0 To dico.Count - 1
      S = Tablo(i)
      Arr = Split(S, "|")
      Range(Cells(42 + i, 3), Cells(42 + i, 4)) = Arr
   Next
   'Affiche les cumuls
   Range("B42").Resize(dico.Count) = Application.Transpose(dico.items)
   Tablo = dico.items
End Sub

A+

Le 23/07/2021 à 17:21

Ahahahah...

Oui J'avais vu ton message... et j'étais en train de travailler dessus. Beaucoup de mal à incrémenter les quantités...Je voulais te répondre mais pas avant d'avoir approfondi. Les dicos pour moi c'est l'enfer mais bon... trop puissant pour ignorer cet outil.

Ca doit faire 4 mois que je fais du VBA j'ai beau passer des heures à trifouiller certains codes, parfois je bloque et je ne peux pas inventer certain truc... et la je commencais à me décourager merci pour le coup de pouce , mais il faudra un peu de temps pour que j'assimile tes deux codes.

Application.transpose reste un mystère, .currentRegion c'est nouveau aussi

Je viens de tester ta dernière solution et c'est absolument fonctionnel. Il me reste à supprimer les nomenclature quand aucune quantité mais avec une boucle for et un if en cherchant dans l'array ca devrait être pas compliqué.

image

Merci beaucoup de m'avoir aidé. Maintenant que ca marche je crois que le travail est d'optimiser les différents modules puisque avec du recul je me dis que c'est vraiment le foutoir niveau code même si j'ai essayer de faire au mieux.

13confpartage-v9.xlsm (192.73 Ko)

Je partage le nouveau fichier qui marche avec la compo une travée 62 m, ca vaut bien une V9

Le 23/07/2021 à 18:20

je me dis que c'est vraiment le foutoir niveau code..

Heu... c'est un euphémisme !

Déjà supprimer Toutes ces déclarations public

Faire les déclarations au niveau Sub : Inutiles de déclarer des variables qui sont déjà déclarées dans le Gestionnaire de noms :

Utilise le nom de ces plages pour tes Range

Ensuite fais en sorte que tous tes array commences par "Arr" ou par "Tab"

ArrCan, ArrTrv, ArrPAF, ArrTyp, ArrHtr et ArrMac devraient convenir

Les variables en une seule lettres devraient être bannies. (sauf à la rigueur i pour les incréments de boucle For...

Les underscores aussi...

Et si ensuite tu rajoutes Option Explicit en haut de chaque module ça t'évitera des heures de recherches :

NB : Pour Option Explicit c'est dans VBA Outils > Options + Cocher Déclarations des varibles obligatoires...

A+

Le 23/07/2021 à 18:35

Salut galopin01, BARNS

Je t ai proposé une solution qui regroupe toutes les possibilités (déférentes colonnes) mais je voix que tu veux additionner la colonne de quantités comme une somme d’articles et supprimer les doublons sur la colonne qui a FB6040, FB6035, FB6038 …. et encore tu veux supprimer les lignes sans nomenclatures.

Alors j ai modifié le premier code pour le rendre plus simple et compréhensible :

Sub test02()
Set Dic = CreateObject("Scripting.Dictionary")
Dim tmps
drlgn = Cells(Rows.Count, 2).End(xlUp).Row
ReDim tmps(1 To 3, 1 To 1)
tbl = Range(Cells(2, "A"), Cells(drlgn, "C"))
  For i = LBound(tbl, 1) To UBound(tbl, 1)
  If tbl(i, 1) <> "" Then
      If Not (Dic.exists(tbl(i, 2))) Then
         n = n + 1
         Dic.Add tbl(i, 2), n
         ReDim Preserve tmps(1 To 3, 1 To n)
         For j = 1 To 3
             tmps(j, n) = tbl(i, j)
         Next
         Else
             h = Dic.Item(tbl(i, 2))
             tmps(1, h) = tmps(1, h) + tbl(i, 1)
         End If
  End If
  Next i
      Cells(2, "I").Resize(drlgn, 3).ClearContents
      Cells(2, "I").Resize(UBound(tmps, 2), 3) = _
      Application.WorksheetFunction.Transpose(tmps) 
      Cells(2, 9).Sort Key1:=Cells(2, 9), Order1:=xlAscending, Header:=xlYes

End Sub
25trys02.xlsm (16.54 Ko)
Le 23/07/2021 à 18:48

Oui mais les Redim, Resize... ça fait un peu crade et puis ça va bien quand tu n'as que 10 lignes à traiter parce que sinon...

Tu me diras que ça te laisse le temps d'aller te faire un joint ou un café Ok... Mébon !

Sinon

Application.Transpose 'ça marche aussi bien !

A+

Le 23/07/2021 à 19:41

Salut galopin01

j ai apprécié bien ta proposition quand tu l a dit aller voir les dictionnaires --

Et quand il est revenu avec le bout de code pour les dictionnaires, je me suis dis voila un autre qui veut bien apprendre et non pas seulement copier et coller les codes.

Alors perso ce genre de personne ; je les respects et j’essaye de répondre selon leur demande.

« Mais je souhaite bien transposer mon array directement dans le dictionnaire, et ici ca cloche un peu. Si quelqu'un peut m'aiguiller ca serait top ».

Redim, Resize. Tu crois que je ne sais pas ça ! Des fois travailler seulement sur les array et a la fin de la procédure remplir les cellules avec sera plus rapide que travailler directement sur les cellules.

Pour Redim, Resize. Je peux simplement allouer les arrays avec la taille des éléments avec leur doublons mais moi je ne fais pas ça parce que a mon avis c’est manque de performance et je ne fait pas ça seulement parce que je veux améliorer mes connaissances !

j ai voulu dire seulement que j ai respecté le veux de BARNS lorsqu’il a dit :

« Mais je souhaite bien transposer mon array directement dans le dictionnaire, et ici ca cloche un peu. Si quelqu'un peut m'aiguiller ca serait top ».

Parce que je voix qu’il veut apprendre et pas seulement copier et coller, j ai voulu le montre comment profiter bien des arrays

Cordialement

Le 23/07/2021 à 20:33

Tout le monde n'est pas parfait moi le premier et je n'ai jamais caché que je ne suis pas un pro.

Je sais que mes propos sont souvent mal ressentis, mais...

Ce que je dis je ne le dis pas pour critiquer, juste pour que tout le monde progresse.

Comme toi j'ai commencé tant bien que mal (et plutôt mal que bien !)

Et aujourd'hui j'en ai plus rien à fiche...

Alors si quelqu'un croit pourvoir me contredire et m'apprendre quelque chose, je prends !

Aussi tu n'as pas à te justifier ! Chacun apporte ce qu'il peut... quand il le peut !

A+

Le 27/08/2021 à 10:26

Après ces petites vacances je remets la tête dans le fichier. Par rapport au derniers messages.

J'ai fait une petite mise à jour du fichier en écoutant les conseils de Galopin :

– tout déclarer

– utiliser arr ou tab pour tout les tableaux

– réduction des variables à une seule lettre

– option explicit pour tout les modules

Effectivement le fait de comprendre me permet de réutiliser les outils.

Et le fait d'avoir plusieurs solutions et avis permet d'avoir différentes perspectives pour voir ce qui me convient le mieux et pour mieux comprendre ! Merci à vous deux pour votre aide précieuse, j'espère que vous avez passé de bonnes vacances!

Rechercher des sujets similaires à "remplir dictionnary array"