Dictionary avec lignes intercalées
Bonjour le forum
Je vous soumet mon sujet en espèrant que ce que je souhaite soit réalisable.
Je réalise à l'aide d'un objet tableau le transfert de données liées par un même numéro (en colonne L) sous forme de ligne.
Celà fonctionne san souci..........sauf que je voudrais pouvoir intercaler une ligne supplémentaire pour chaque groupe
Je joint le fichier qui contient les données traitées ainsi qu'un exemple de ce que je souhaite.
Je vous remercie par avance pour toute l'aide que vous pourrez m'apporter.
Cdlt
Voici le programme.
Sub CORR()
Range("P2:P5") = ""
Set d = CreateObject("Scripting.Dictionary")
For Each c In Range("L2", [L65000].End(xlUp))
If c <> "" Then
If d.Exists(c.Value) Then
d(c.Value) = d(c.Value) & "B(" & c.Offset(0, -2) & "*" & c.Offset(0, -1) & ")"
Else
d(c.Value) = "TEST " & d(c.Value) & "B(" & c.Offset(0, -2) & "*" & c.Offset(0, -1) & ")"
End If
End If
Next c
[P2].Resize(d.Count) = Application.Transpose(d.items)
End Subbonjour jp65, en utilisant une 2eme matrice
Sub CORR()
Range("P2:P100").ClearContents
Set d = CreateObject("Scripting.Dictionary")
For Each c In Range("L2", [L65000].End(xlUp))
If c <> "" Then
If d.Exists(c.Value) Then
d(c.Value) = d(c.Value) & "B(" & c.Offset(0, -2) & "*" & c.Offset(0, -1) & ")"
Else
d(c.Value) = "TEST " & d(c.Value) & "B(" & c.Offset(0, -2) & "*" & c.Offset(0, -1) & ")"
End If
End If
Next c
If d.Count = 0 Then Exit Sub
n = d.Count
If n = 1 Then d([Rnd]) = [Rnd] 'ajouter un record "DUMMY" s'il n'y a qu'un record dans le dictionaire
arr = d.items
ReDim arr2(1 To n * 2, 1 To 1) '2eme matrice
For i = 1 To n
arr2(i * 2 - 1, 1) = arr(i - 1)
arr2(i * 2, 1) = "BONJOUR " & Mid(arr(i - 1), 5)
Next
[P2].Resize(UBound(arr2)) = arr2
End SubBonjour BsALv
Merci pour cette réponse rapide qui couvre parfaitement mon besoin.
Cdlt
Re bonjour
Mon besoin a évolué et j'en remet donc une couche.
Avec le code fourni par BsALv la ligne intercalée reprend les même données que la ligne initiale sans les 5 premiers caractères.
Ce qui est parfaitement normal car mon exemple sur le fichier était ainsi fait.
Maintenant il faudrait que je puisse choisir le contenu de la deuxième ligne (en piochant dans les diverses colonnes) comme je l'ai fait dans mon programme de base avec la définition des d(c.value)
ex:
La première ligne récupère les données du groupe en piochant dans les colonnes J et K + mise en forme (parenthèses, *, etc...). C'est le code de base
La deuxième ligne devrait pouvoir récupérer au choix les données dans les mêmes colonnes, ou d'autres.
En travaillant sur mon projet je pensais créer deux dictionary avec dans chacun les données qui m'intéressent mais je ne sais pas si l'on peut ensuite combiner les deux tableaux afin d'arriver aux lignes intercalées que je souhaite.
Cdlt
re,
En principe, ces 2 dictionaires, cela doit fonctionner, mais je ne suis pas 100% (seulement 99.99%) sûr que joindre les 2 sera correct.
Au lieu un dictionaire et au lieu d'un string comme item, c'est maintenant un array de 2 éléments (ou même plus élevé, si nécessaire) que vous pouvez modifier pendant le boucle
Sub CORR()
Range("P2:P100").ClearContents
Set d = CreateObject("Scripting.Dictionary")
For Each c In Range("L2", [L65000].End(xlUp))
If c <> "" Then
If Not d.Exists(c.Value) Then d(c.Value) = Array("", "") 'comme item un array de 2 éléments, pour le moment vide
it = d(c.Value) 'item actuel de ce clé (donc un array de 2 éléments)
it(0) = it(0) & "B(" & c.Offset(0, -2) & "*" & c.Offset(0, -1) & ")" 'modifier 1er element
it(1) = it(1) & " (" & c.Offset(0, -1) & ")" & " * B(" & c.Offset(0, -2) 'modifier 2eme élément (juste l'inverse du 1er)
d(c.Value) = it 'mettre à jour cet item du clé dans le dictionaire
End If
Next c
If d.Count = 0 Then Exit Sub
n = d.Count
If n = 1 Then d([Rnd]) = d.items()(0) 'ajouter un record DUMMY s'il n'y a qu'un record dans le dictionaire (item du dummy est le même que le 1er)
arr = Application.Index(d.items, 0, 0) 'lire le contenu des items
ReDim arr2(1 To n * 2, 1 To 1) 'créer 2eme matrice
For i = 1 To n
arr2(i * 2 - 1, 1) = arr(i, 1)
arr2(i * 2, 1) = arr(i, 2)
Next
[P2].Resize(UBound(arr2)) = arr2
End SubMerci BsALv une nouvelle fois pour ton aide.
Ton dernier code est impeccable (et lisible grâce au commentaires ajoutés).
J'ai ajouté une condition sur chaque it pour inscrire un texte quand la définition du groupe est terminée.
Cdlt
Sub CORR3()
Columns("P:S").Delete Shift:=xlToLeft0
Set d = CreateObject("Scripting.Dictionary")
For Each c In Range("L2", [L65000].End(xlUp))
If c <> "" Then
'Comme item un array de 2 éléments, pour le moment vide
If Not d.exists(c.Value) Then d(c.Value) = Array("", "")
'Ttem actuel de ce clé (donc un array de 2 éléments)
it = d(c.Value)
'Modifier 1er élément
If it(0) <> "" Then
it(0) = it(0) & "B(" & c.Offset(0, -2) & "*" & c.Offset(0, -1) & ")"
Else
it(0) = "OULALA " & it(0) & "B(" & c.Offset(0, -2) & "*" & c.Offset(0, -1) & ")"
End If
'Modifier 2eme élément
If it(1) <> "" Then
it(1) = it(1) & " (" & c.Offset(0, -1) & ")" & " * B(" & c.Offset(0, -2)
Else
it(1) = "MERCI BsALv " & it(1) & " (" & c.Offset(0, -1) & ")" & " * B(" & c.Offset(0, -2)
End If
'Mettre à jour cet item du clé dans le dictionaire
d(c.Value) = it
End If
Next c
If d.Count = 0 Then Exit Sub
n = d.Count
'Ajouter un record DUMMY s'il n'y a qu'un record dans le dictionaire (item du dummy est le même que le 1er)
If n = 1 Then d([Rnd]) = d.items()(0)
'Lire le contenu des items
arr = Application.Index(d.items, 0, 0)
'Créer 2eme matrice
ReDim arr2(1 To n * 2, 1 To 1)
For i = 1 To n
arr2(i * 2 - 1, 1) = arr(i, 1)
arr2(i * 2, 1) = arr(i, 2)
Next
[P2].Resize(UBound(arr2)) = arr2
End Subre,
je ne comprends pas bien ce que vous dites là, n'est ce pas mieux d'ajouter ces 2 textes dans ce boucle ?
For i = 1 To n
arr2(i * 2 - 1, 1) = " OULALA " & arr(i, 1)
arr2(i * 2, 1) = " Merci Bsalv " & arr(i, 2)
NextBonjour
BsALv effectivement c'est plus souple et réduit le nombre de lignes de code.
Cdlt
bonjour,
A+