Ca ne rentre pas à chaque fois dans ma tête ! (dictionnary)
Hello tous,
J'ai déjà réussi à faire des macros avec Dictionnary mais là , c'est tout simple en apparence, mais je bloque...
Un tableau sur la partie gauche de l'écran ,en 4 colonnes, mais il pourrait y en avoir plus; un nombre de lignes avec des noms en multiples exemplaires et qui peuvent être bien sur plusieurs milliers; l'exemple en montre peu mais c'est pour connaitre la marche à suivre qu'il est fait.
Je dois faire un résumé autrement qu'avec TCD ou sommeprod et autres formules diverses; je tiens à faire ça en vba parce que la vitesse est un critère si j'ai 10.000 lignes et 40 colonnes
Merci de votre aide précieuse !
Patrick
Bonjour,
Une piste à améliorée mais ça te donne le résultat voulu :
Sub RegrouperParNoms()
Dim Dico As Object
Dim Plage As Range
Dim Cel As Range
Dim NumCol As Long
Dim I As Long
Dim Chaine As String
Dim Cle
With Worksheets("Feuil1")
'défini la plage sur la colonne A
Set Plage = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
'récup du nombre de colonnes sur la linge 1
NumCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'vide les cellules en décalé d'une colonne à droite de la plage, dans l'exemple F1:J17
Plage.Offset(, NumCol + 1).Resize(Plage.Rows.Count, Plage.Columns.Count + NumCol).Clear
Set Dico = CreateObject("Scripting.Dictionary")
'parcour la plage (colonne A)
For Each Cel In Plage
'si la clé n'existe pas...
If Dico.exists(Cel.Value) = False Then
'construction de la chaine
For I = 1 To NumCol
Chaine = Chaine & Cel.Offset(, I).Value & ";"
Next I
'création de la clé et ajout de la chaine
Dico.Add Cel.Value, Chaine
'efface
Chaine = ""
'si la clé existe déjà...
Else
'ajoute les valeurs manquantes
For I = 1 To NumCol
If Split(Dico(Cel.Value), ";")(I - 1) = "" Then
Chaine = Chaine & Cel.Offset(, I).Value & ";"
Else
Chaine = Chaine & Split(Dico(Cel.Value), ";")(I - 1) & ";"
End If
Next I
'puis remplacement de la valeur par la nouvelle
Dico(Cel.Value) = Chaine
'efface
Chaine = ""
End If
Next Cel
I = 0
'colle dans la zone précédemment vidée. Pour plus de rapidité, à voir ici pour l'utilisation d'un tableau intermédiaire !!!
For Each Cle In Dico.Keys
I = I + 1
Range("F" & I) = Cle
Range("G" & I & ":I" & I) = Split(Dico(Cle), ";")
Next Cle
End SubAvec un tableau et avec une petite correction au niveau de la recherche de la dernière colonne (pour le vidage des cellules) :
Sub RegrouperParNoms()
Dim Dico As Object
Dim Plage As Range
Dim Cel As Range
Dim Tbl() As String
Dim NumCol As Long
Dim I As Long
Dim J As Integer
Dim Chaine As String
Dim Cle
With Worksheets("Feuil1")
'défini la plage sur la colonne A
Set Plage = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
'récup du nombre de colonnes sur la linge 1
NumCol = .Cells(1, 1).End(xlToRight).Column
End With
'vide les cellules en décalé d'une colonne à droite de la plage, dans l'exemple F1:J17
Plage.Offset(, NumCol + 1).Resize(Plage.Rows.Count, Plage.Columns.Count + NumCol).Clear
Set Dico = CreateObject("Scripting.Dictionary")
'parcour la plage (colonne A)
For Each Cel In Plage
'si la clé n'existe pas...
If Dico.exists(Cel.Value) = False Then
'construction de la chaine
For I = 1 To NumCol
Chaine = Chaine & Cel.Offset(, I).Value & ";"
Next I
'création de la clé et ajout de la chaine
Dico.Add Cel.Value, Chaine
'efface
Chaine = ""
'si la clé existe déjà...
Else
'ajoute les valeurs manquantes
For I = 1 To NumCol
If Split(Dico(Cel.Value), ";")(I - 1) = "" Then
Chaine = Chaine & Cel.Offset(, I).Value & ";"
Else
Chaine = Chaine & Split(Dico(Cel.Value), ";")(I - 1) & ";"
End If
Next I
'puis remplacement de la valeur par la nouvelle
Dico(Cel.Value) = Chaine
'efface
Chaine = ""
End If
Next Cel
I = 0
ReDim Tbl(1 To Dico.Count, 1 To NumCol)
'colle dans la zone précédemment vidée
For Each Cle In Dico.Keys
I = I + 1
Tbl(I, 1) = Cle
For J = 2 To UBound(Split(Dico(Cle), ";"))
Tbl(I, J) = Split(Dico(Cle), ";")(J - 2)
Next J
Next Cle
Range(Cells(1, NumCol + 2), Cells(Dico.Count, NumCol * 2 + 1)) = Tbl
End SubBonjour,
Si j'ai compris ce que tu veux obtenir (pas sûr ! certains éléments de ton cheminement m'ont un peu troublé), j'aurais procédé ainsi avec éléments que tu as mis en avant (c'est un peu différent de Thèze, que j'ai regardé rapidement au passage) :
Sub RegrouperParNoms()
Dim Dico As Object
Dim C
Dim Tablo
Dim A, I
Set Dico = CreateObject("Scripting.Dictionary")
For Each C In Range("a1", [a65000].End(xlUp))
A = Array(C.Value, C.Offset(0, 1), C.Offset(0, 2), C.Offset(0, 3))
If Dico.exists(C.Value) Then
Tablo = Split(Dico(C.Value), "|")
For I = 0 To UBound(A)
If IsEmpty(A(I)) Then A(I) = Tablo(I)
Next I
End If
Dico(C.Value) = Join(A, "|")
Next C
[G2].CurrentRegion.ClearContents
Tablo = Dico.items
C = 0
For I = LBound(Tablo) To UBound(Tablo)
A = Split(Tablo(I), "|")
C = C + 1
Range("G" & C).Resize(, UBound(Tablo)) = A
Next I
End SubCordialement.
Re bonjour à vous 2, et aux autres
je teste ça lundi et je vous tiens au jus
Merci déjà !
P.
Bonsoir le forum,
Salut patrick,
Pas trop compris le contexte
On voit toujours apparaitre la même occurence dans chacune de tes colonnes (2 à 4), est-ce normal ?
Option Explicit
Sub test()
Dim a, i As Long, j As Long, n As Long, w()
With Sheets(1).Range("a1").CurrentRegion
a = .Value
ReDim w(1 To UBound(a, 2)): n = 1
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
n = n + 1
w(1) = n
a(n, 1) = a(i, 1)
For j = 2 To UBound(a, 2)
Set w(j) = CreateObject("Scripting.Dictionary")
w(j).CompareMode = 1
If a(i, j) <> "" Then
w(j)(a(i, j)) = Empty
End If
a(n, j) = a(i, j)
Next
.Item(a(i, 1)) = w
Else
w = .Item(a(i, 1))
For j = 2 To UBound(a, 2)
If a(i, j) <> "" Then
If Not w(j).exists(a(i, j)) Then
a(w(1), j) = a(i, j)
w(j)(a(i, j)) = Empty
.Item(a(i, 1)) = w
End If
End If
Next
End If
Next
End With
Application.ScreenUpdating = False
'Restitution
With .Offset(, .Columns.Count + 2)
.Cells(1).CurrentRegion.Clear
With .Resize(n, UBound(a, 2))
.Value = a
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.VerticalAlignment = xlCenter
With .Rows(1)
.Interior.ColorIndex = 36
End With
End With
End With
Application.ScreenUpdating = True
End With
End Subklin89
Re patrick,
Vu le contexte, plus simple :
Option Explicit
Sub test1()
Dim a, i As Long, j As Byte, w(), y, x
With Sheets(1).Range("a1").CurrentRegion
a = .Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
ReDim w(1 To UBound(a, 2))
For j = 1 To UBound(a, 2)
w(j) = a(i, j)
Next
.Item(a(i, 1)) = w
Else
w = .Item(a(i, 1))
For j = 2 To UBound(a, 2)
If a(i, j) <> "" Then
If w(j) = "" Then
w(j) = a(i, j)
End If
End If
Next
.Item(a(i, 1)) = w
End If
Next
y = .Count: x = .items
End With
Application.ScreenUpdating = False
'Restitution
With .Offset(, .Columns.Count + 2)
With .Cells(1)
.CurrentRegion.Clear
.Resize(1, UBound(a, 2)).Value = a
.Offset(1).Resize(y, UBound(a, 2)).Value = Application.Index(x, 0, 0)
With .CurrentRegion
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.VerticalAlignment = xlCenter
With .Rows(1)
.Interior.ColorIndex = 36
End With
End With
End With
End With
Application.ScreenUpdating = True
End With
End Subklin89
Hello à tous,
Alors, avec un test sur vos différents codes, c'est génial comme toujours
J'ai essayé avec le tableau déposé au premier post:
Theze: tel quel , le tableau se reproduit tel que le résultat escompté
si j'ajoute une personne sur plusieurs lignes , pas de souci
si j'insère une colonne en 2e position par ex, c'est OK aussi
(merci pour les commentaires dans le code)
MFerrand (code plus court et plus simple à comprendre -pour mon esprit mononeurone- )
tableau originel: OK
avec une personne en plus et sur plusieurs lignes:Ok
en insérant une colonne en plus en 2e position: Ok
klin89 Idem, tout fonctionne mais j'ai aussi vu de nombreuses bonnes réponses de sa part sur différents sujets
Donc, bravo à vous tous, je garde ça précieusement et j'utiliserai certainement encore dans le futur en adaptant à mes autres classeurs ou pour tenter des réponses -- adaptées -- à d'autres participants.
Merci à vous tous !
Ceci dit, je poserai surement encore un ou l'autre question à l'avenir parce que j'ai du mal à appréhender les dico et leur clé , même si j'en comprends le principe et que j'ai parcouru le site de Boisgontier et...que je sais parfois répondre sur des codes plus simples; ici le mélange tableau/dico (code de Klin89) me perturbe mais tout en sachant que sur un grand nombre de données il est rapide.
Patrick (qui aurait besoin de cours en "dicologie"