scripting.dictionnary et restitution de données

[gosselien]

Hello le forum et les VBA istes en particulier,

je commence à tester les dictionnaires en m'inspirant de codes existants mais...
je ne pige pas tout, loin de là.

J'essaie dans une feuille de trouver les adresses mail qui peuvent être n'importe où dans cette feuille, et de les copier en sans doublon en colonne A;
jusque là, ça fonctionne mais quand je veux mettre en commentaire l'adresse j'ai 2 soucis:
1) j'ajoute bien un commentaire dans la cellule mais il contient toujours le chiffre 1
2) je voudrais avoir le choix de mettre dans ce commentaire soit 1 adresse de cellule par mail trouvé soit toutes les adresses des cellules trouvées qui ont un mail en cas de doublons...
Donc, je bloque, ne connaissant pas encore les tableaux et dictionnaires comme il le faudrait
C'est un exercice qui pourra servir dans d'autres situations, donc je pourrai adapter si je comprends déjà mon erreur ici au niveau dd l'ajout du commentaire.
Merci de votre aide (et de commenter le code que vous pourriez ajouter/modifier)

P.

 

[pierrejean]

Re : scripting.dictionnary et restitution de données

Bonjour gosselien

Vois si cela te convient

Je pense que tu pourra voir aisément les petites modifs apportées à ton code

 

[gosselien]

Re : scripting.dictionnary et restitution de données

Merci Pierrejean..

en effet peu de changements mais bénéfiques !!!
Merci

Je vais vois ça de plus près pour encore modifier et mettre les lignes en remarques opérationelles

Patrick

 

[gosselien]

Re : scripting.dictionnary et restitution de données

re,

je tente de modifier/améliorer ce code de Pierre et je patauge..
je cherche (ça n'est peut être pas possible de cette manière) à copier en + la couleur de fond des cellules d'une manière ou l'autre...

voilà une partie du codeje cherche le @ dans les cellulles)
Les adresses mails sont parfois en double mais je ne garde qu'un exemplaire de chacune et s'il elle est mémorisée, je dois pouvoir mémoriser la couleur de la cellule aussi non ?

Merci
Et si vous savez où trouver un bon endroit pour apprendre les tableaux et dictionnaires, je suis preneur


Selection.SpecialCells(xlCellTypeConstants, 2).Select
For Each C In Selection
Trouve = IIf(InStr(1, C.Value, Texte) > 1, 1, 0)
If Trouve >= 1 Then
Clé = C.Value ' valeur de la cellule
Adr = C.Address ' adresse de la cellule
Dico.Item(Clé) = Dico.Item(Clé) + 1
End If
Next C

' déposer les items trouvés sur la zone prévue (A2 de feuille Destination)
Dest.Resize(Dico.Count) = Application.Transpose(Dico.Keys)
Dest.Resize(Dico.Count, 2).Sort Dest, xlAscending, Header:=xlNo, Orientation:=xlTopToBottom

' ------------ ajout couleur

For Each Cel In Selection
Trouve = IIf(InStr(1, Cel.Value, Texte) > 1, 1, 0)
If Trouve >= 1 Then
'clé = Cel.Value ' valeur de la cellule
Mclé = Cel.Interior.ColorIndex
'clé = Mcoul
If Not Dico2.Exists(Mclé) Then Dico2.Add Mclé, Mclé
'dico2.Item(clé) = dico2.Item(clé) + 1
End If
Next Cel

 

[job75]

Re : scripting.dictionnary et restitution de données

Bonjour gosselien, Pierre,

Dans le code de la feuille :

Sub ListeMails()
Dim r As Range, d As Object, x, a, b, i&, s
Set r = Me.UsedRange
Set d = CreateObject("Scripting.Dictionary")
For Each r In r
  If r.Column > 1 And InStr(r, "@") Then
    x = r
    If d.exists(x) Then
      d(x) = d(x) & " " & r.Address(0, 0)
    Else
      d(x) = r.Interior.Color & "." & r.Font.Color & "." & r.Address(0, 0)
    End If
  End If
Next
'---restitution en colonne A---
Application.ScreenUpdating = False
Range("A2:A" & Rows.Count).Clear
Columns(1).AutoFit
If d.Count = 0 Then Exit Sub
a = d.keys: b = d.items
For i = 0 To UBound(a)
  Cells(i + 2, 1) = a(i)
  s = Split(b(i), ".")
  Cells(i + 2, 1).Interior.Color = s(0)
  Cells(i + 2, 1).Font.Color = s(1)
  With Cells(i + 2, 1).AddComment
    .Visible = False
    .Text s(2)
    .Shape.TextFrame.AutoSize = True
  End With
Next
Columns(1).AutoFit
End Sub

Couleur de fond et couleur de police sont copiées.

Fichier joint.

A+

 

[gosselien]

Re : scripting.dictionnary et restitution de données

Waouwww, merci Job !!!

j'ai bcp de mal à comprendre certaines lignes mais ça fonctionne bien sur ...
Aurais-tu l'amabilité de commenter le code là où je ne comprends pas..
Je remets le code VBA du fichier avec OK quand j'ai compris ce qu'il fait et ? pour les lignes non comprises...

Sub ListeMails()
Dim r As Range, d As Object, x, a, b, i&, s ' déclaration des variables OK
Set r = Me.UsedRange ' ? ME
Set d = CreateObject("Scripting.Dictionary")
For Each r In r ' pour chaque cellule dans le range "r"
If r.Column > 1 And InStr(r, "@") Then ' si r est non vide et on y trouve @ OK
x = r ' ?
If d.exists(x) Then ' ?
d(x) = d(x) & " " & r.Address(0, 0) ' on ajoute un espace pourquoi ? et l'adresse de la cellule pourquoi 0,0 ?
Else ' ? si ça n'existe pas dans le dico on l'y ajoute ?
d(x) = r.Interior.Color & "." & r.Font.Color & "." & r.Address(0, 0)
End If
End If
Next
'---restitution en colonne A---
Application.ScreenUpdating = False ' OK
Range("A2:A" & Rows.Count).Clear ' OK
Columns(1).AutoFit ' OK
If d.Count = 0 Then Exit Sub ' si vide on sort OK
a = d.keys
b = d.items ' pourquoi a= et b= ?

For i = 0 To UBound(a) ' boucle de 1 à nombre d'occurences
Cells(i + 2, 1) = a(i) ' on commence en ligne 2, colonne 1 et on incrémente les lignes
s = Split(b(i), ".") ' on cherche le "." ? mais on en a ajouté 2 plus haut ???
Cells(i + 2, 1).Interior.Color = s(0) ' ? interior.color ok mais s(0) ???
Cells(i + 2, 1).Font.Color = s(1) ' idem s(1) ?
With Cells(i + 2, 1).AddComment ' ok
.Visible = False 'ok
.Text s(2) ' ?
.Shape.TextFrame.AutoSize = True ' ok
End With
Next
Columns(1).AutoFit
End Sub

 

[job75]

Re : scripting.dictionnary et restitution de données

Re,

Sub ListeMails()
Dim r As Range, d As Object, x, a, b, i&, s ' déclaration des variables OK
Set r = Me.UsedRange ' ? ME c'est la feuille où se trouve le code
Set d = CreateObject("Scripting.Dictionary")
For Each r In r ' pour chaque cellule dans le range "r"
If r.Column > 1 And InStr(r, "@") Then ' si r n'est pas en colonne A et on y trouve @ OK
x = r ' ? scalaire plus rapide, évite de répéter r.Value
If d.exists(x) Then ' ? évident
d(x) = d(x) & " " & r.Address(0, 0) ' on ajoute un espace pourquoi ? bah pour séparer les adresse et l'adresse de la cellule pourquoi 0,0 ? testez sans ces arguments...
Else ' ? si ça n'existe pas dans le dico on l'y ajoute ? oui en mémorisant ce qui est indiqué
d(x) = r.Interior.Color & "." & r.Font.Color & "." & r.Address(0, 0)
End If
End If
Next
'---restitution en colonne A---
Application.ScreenUpdating = False ' OK
Range("A2:A" & Rows.Count).Clear ' OK
Columns(1).AutoFit ' OK
If d.Count = 0 Then Exit Sub ' si vide on sort OK
a = d.keys
b = d.items ' pourquoi a= et b= ? on crée des tableaux (array) qu'on peut analyser

For i = 0 To UBound(a) ' boucle de 1 à nombre d'occurences les "array" commencent toujours à 0
Cells(i + 2, 1) = a(i) ' on commence en ligne 2, colonne 1 et on incrémente les lignes
s = Split(b(i), ".") ' on cherche le "." ? mais on en a ajouté 2 plus haut ??? voir l'aide VBA sur Split
Cells(i + 2, 1).Interior.Color = s(0) ' ? interior.color ok mais s(0) ??? 1er élément de l'array s
Cells(i + 2, 1).Font.Color = s(1) ' idem s(1) ?
With Cells(i + 2, 1).AddComment ' ok
.Visible = False 'ok
.Text s(2) ' ?
.Shape.TextFrame.AutoSize = True ' ok
End With
Next
Columns(1).AutoFit
End Sub

A+

 

[gosselien]

Re : scripting.dictionnary et restitution de données

Merci pour tout ça !

je vais relire en faisant du pas à pas

Patrick