decalage...

Bonjour,

Essaie comme ceci en adaptant le nom de la feuille et de la plage de cellules au besoin


Sub test()

Dim Rg As Range, C As Range

With Worksheets("Feuil1")
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
Application.EnableEvents = False
For Each C In Rg
If C.Value = C.Offset(1) Then
If C.Offset(, 1) <> "" Then
m = m & C.Offset(, 1).Value & ","
End If
Else
If C.Offset(, 1) <> "" Then
m = m & C.Offset(, 1).Value & ","
End If
C.Offset(, 2) = Left(m, Len(m) - 1)
m = ""
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub




MichD
--------------------------------------------
"MANU" a écrit dans le message de groupe de discussion : io6k9c$8f4$1@speranza.aioe.org...

Bonjour,

J'ai ceci :

A B
1 aa lulu
2 aa
3 aa toto
4 aa mimi
5 aa
6 xd rené
7 xd
8 xd lili


Je souhaite en colonne C faire une formule qui permette de reunir toutes les
personnes (Col B) de la meme categorie (Col A) et je souhaiterais que ce
resultat se mette en face de la derniere categorie.

Par consequent, dans cette exemple, je devrais avoir comme resultat :
Rien de C1 à C4
En C5 : lulu ; toto ; mimi
Rien de C6 à C7
En C8 : rené ; lili

Pas facile du tout. Ais je été assez clair ?

Merci

Manu

Waouuu

Comme dab, c'est nickel, Merci Mich. et si j'abusais... est t'il possible de
lui demander de ne pas mettre plus d'une fois le meme nom pour la meme
categorie, j'explique :

A B
1 aa lulu
2 aa
3 aa mimi
4 aa mimi
5 aa
6 xd rené
7 xd
8 xd lili
9 xd rené

Je devrais avoir comme resultat :
Rien de C1 à C4
En C5 : lulu ; mimi
(et non lulu ; mimi ; mimi)
Rien de C6 à C8
En C9 : rené ; lili
(et non rené ; lili ; rené)

Merci

Manu




"MichD" <michdenis@hotmail.com> a écrit dans le message de news:
io6lob$c3c$1@speranza.aioe.org...

Bonjour,

Essaie comme ceci en adaptant le nom de la feuille et de la plage de
cellules au besoin


Sub test()

Dim Rg As Range, C As Range

With Worksheets("Feuil1")
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
Application.EnableEvents = False
For Each C In Rg
If C.Value = C.Offset(1) Then
If C.Offset(, 1) <> "" Then
m = m & C.Offset(, 1).Value & ","
End If
Else
If C.Offset(, 1) <> "" Then
m = m & C.Offset(, 1).Value & ","
End If
C.Offset(, 2) = Left(m, Len(m) - 1)
m = ""
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub




MichD
--------------------------------------------
"MANU" a écrit dans le message de groupe de discussion :
io6k9c$8f4$1@speranza.aioe.org...

Bonjour,

J'ai ceci :

A B
1 aa lulu
2 aa
3 aa toto
4 aa mimi
5 aa
6 xd rené
7 xd
8 xd lili


Je souhaite en colonne C faire une formule qui permette de reunir toutes
les
personnes (Col B) de la meme categorie (Col A) et je souhaiterais que ce
resultat se mette en face de la derniere categorie.

Par consequent, dans cette exemple, je devrais avoir comme resultat :
Rien de C1 à C4
En C5 : lulu ; toto ; mimi
Rien de C6 à C7
En C8 : rené ; lili

Pas facile du tout. Ais je été assez clair ?

Merci

Manu

Essaie ceci :

'-------------------------------------
Sub test()

Dim Rg As Range, C As Range
Dim Dic As Object, M As String, T()

With Worksheets("Feuil1")
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
Application.EnableEvents = False
Set Dic = CreateObject("Scripting.Dictionary")
For Each C In Rg
If C.Value = C.Offset(1) Then
If C.Offset(, 1) <> "" Then
If Not Dic.Exists(C.Offset(, 1).Value) Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
Else
If C.Offset(, 1) <> "" Then
If Not Dic.Exists("Emilie") Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
C.Offset(, 2) = Left(M, Len(M) - 1)
M = ""
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'-------------------------------------


MichD
--------------------------------------------

Bonjour,

Ca bug sur cette ligne : Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)

Manu

"MichD" <michdenis@hotmail.com> a écrit dans le message de news:
io7d31$97a$1@speranza.aioe.org...

Essaie ceci :

'-------------------------------------
Sub test()

Dim Rg As Range, C As Range
Dim Dic As Object, M As String, T()

With Worksheets("Feuil1")
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
Application.EnableEvents = False
Set Dic = CreateObject("Scripting.Dictionary")
For Each C In Rg
If C.Value = C.Offset(1) Then
If C.Offset(, 1) <> "" Then
If Not Dic.Exists(C.Offset(, 1).Value) Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
Else
If C.Offset(, 1) <> "" Then
If Not Dic.Exists("Emilie") Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
C.Offset(, 2) = Left(M, Len(M) - 1)
M = ""
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'-------------------------------------


MichD
--------------------------------------------

J'ai modifié un peu la procédure,

Si tu as un message d'erreur, tu pourrais l'écrire dans ton message
et tu pourrais aussi dire qu'elle est la valeur de C.Offset(, 1)
'---------------------------------
Sub test()

Dim Rg As Range, C As Range
Dim Dic As Object, M As String, T()

With Worksheets("Feuil1")
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
Application.EnableEvents = False
Set Dic = CreateObject("Scripting.Dictionary")
For Each C In Rg
If C.Value = C.Offset(1) Then
If C.Offset(, 1) <> "" Then
If Not Dic.Exists(C.Offset(, 1).Value) Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
Else
If C.Offset(, 1) <> "" Then
M = M & C.Offset(, 1).Value & ","
End If
If M <> "" Then
C.Offset(, 2) = Left(M, Len(M) - 1)
M = ""
End If
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'---------------------------------

MichD
--------------------------------------------
"Manu" a écrit dans le message de groupe de discussion : 4da7db85$0$5413$ba4acef3@reader.news.orange.fr...

Bonjour,

Ca bug sur cette ligne : Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)

Manu

"MichD" <michdenis@hotmail.com> a écrit dans le message de news:
io7d31$97a$1@speranza.aioe.org...

Essaie ceci :

'-------------------------------------
Sub test()

Dim Rg As Range, C As Range
Dim Dic As Object, M As String, T()

With Worksheets("Feuil1")
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
Application.EnableEvents = False
Set Dic = CreateObject("Scripting.Dictionary")
For Each C In Rg
If C.Value = C.Offset(1) Then
If C.Offset(, 1) <> "" Then
If Not Dic.Exists(C.Offset(, 1).Value) Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
Else
If C.Offset(, 1) <> "" Then
If Not Dic.Exists("Emilie") Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
C.Offset(, 2) = Left(M, Len(M) - 1)
M = ""
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'-------------------------------------


MichD
--------------------------------------------

Bonsoir,

Houlala... c'est du chinois pour moi le C.Offset(, 1)

Je n'ais plus de message d'erreur, mais ca ne fonctionne pas, le resultat
est bon, mais il preserve les doublons tout comme ton 1er code. Pour info je
suis sur 2003

Merci Mich, ne te casse pas la tete davantage, ce que tu as deja fais est
deja genial. merci encore

Manu

"MichD" <michdenis@hotmail.com> a écrit dans le message de news:
io96dq$6cs$1@speranza.aioe.org...

J'ai modifié un peu la procédure,

Si tu as un message d'erreur, tu pourrais l'écrire dans ton message
et tu pourrais aussi dire qu'elle est la valeur de C.Offset(, 1)
'---------------------------------
Sub test()

Dim Rg As Range, C As Range
Dim Dic As Object, M As String, T()

With Worksheets("Feuil1")
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
Application.EnableEvents = False
Set Dic = CreateObject("Scripting.Dictionary")
For Each C In Rg
If C.Value = C.Offset(1) Then
If C.Offset(, 1) <> "" Then
If Not Dic.Exists(C.Offset(, 1).Value) Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
Else
If C.Offset(, 1) <> "" Then
M = M & C.Offset(, 1).Value & ","
End If
If M <> "" Then
C.Offset(, 2) = Left(M, Len(M) - 1)
M = ""
End If
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'---------------------------------

MichD
--------------------------------------------
"Manu" a écrit dans le message de groupe de discussion :
4da7db85$0$5413$ba4acef3@reader.news.orange.fr...

Bonjour,

Ca bug sur cette ligne : Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)

Manu

"MichD" <michdenis@hotmail.com> a écrit dans le message de news:
io7d31$97a$1@speranza.aioe.org...

Essaie ceci :

'-------------------------------------
Sub test()

Dim Rg As Range, C As Range
Dim Dic As Object, M As String, T()

With Worksheets("Feuil1")
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
Application.EnableEvents = False
Set Dic = CreateObject("Scripting.Dictionary")
For Each C In Rg
If C.Value = C.Offset(1) Then
If C.Offset(, 1) <> "" Then
If Not Dic.Exists(C.Offset(, 1).Value) Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
Else
If C.Offset(, 1) <> "" Then
If Not Dic.Exists("Emilie") Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
C.Offset(, 2) = Left(M, Len(M) - 1)
M = ""
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'-------------------------------------


MichD
--------------------------------------------

OK, ça devrait rouler. La procédure est insensible à la casse des caractères
Si tu désires le contraire, enlève la présence de la fonction Ucase() dans
toute la procédure.

'------------------------------------
Sub test()

Dim Rg As Range, C As Range
Dim Dic As Object, M As String, T()

With Worksheets("Feuil2")
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
Application.EnableEvents = False
Set Dic = CreateObject("Scripting.Dictionary")
For Each C In Rg
If C.Value = C.Offset(1) Then
If C.Offset(, 1) <> "" Then
If Not Dic.Exists(UCase(C.Offset(, 1).Value)) Then
Dic.Add UCase(C.Offset(, 1).Value), UCase(C.Offset(, 1))
M = M & C.Offset(, 1).Value & ","
End If
End If
Else
If C.Offset(, 1) <> "" Then
If Not Dic.Exists(UCase(C.Offset(, 1).Value)) Then
Dic.Add UCase(C.Offset(, 1).Value), UCase(C.Offset(, 1))
M = M & C.Offset(, 1).Value & ","
End If
End If
If M <> "" Then
C.Offset(, 2) = Left(M, Len(M) - 1)
M = ""
End If
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'------------------------------------




MichD
--------------------------------------------
"MANU" a écrit dans le message de groupe de discussion : io9tj0$41s$1@speranza.aioe.org...

Bonsoir,

Houlala... c'est du chinois pour moi le C.Offset(, 1)

Je n'ais plus de message d'erreur, mais ca ne fonctionne pas, le resultat
est bon, mais il preserve les doublons tout comme ton 1er code. Pour info je
suis sur 2003

Merci Mich, ne te casse pas la tete davantage, ce que tu as deja fais est
deja genial. merci encore

Manu

"MichD" <michdenis@hotmail.com> a écrit dans le message de news:
io96dq$6cs$1@speranza.aioe.org...

J'ai modifié un peu la procédure,

Si tu as un message d'erreur, tu pourrais l'écrire dans ton message
et tu pourrais aussi dire qu'elle est la valeur de C.Offset(, 1)
'---------------------------------
Sub test()

Dim Rg As Range, C As Range
Dim Dic As Object, M As String, T()

With Worksheets("Feuil1")
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
Application.EnableEvents = False
Set Dic = CreateObject("Scripting.Dictionary")
For Each C In Rg
If C.Value = C.Offset(1) Then
If C.Offset(, 1) <> "" Then
If Not Dic.Exists(C.Offset(, 1).Value) Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
Else
If C.Offset(, 1) <> "" Then
M = M & C.Offset(, 1).Value & ","
End If
If M <> "" Then
C.Offset(, 2) = Left(M, Len(M) - 1)
M = ""
End If
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'---------------------------------

MichD
--------------------------------------------
"Manu" a écrit dans le message de groupe de discussion :
4da7db85$0$5413$ba4acef3@reader.news.orange.fr...

Bonjour,

Ca bug sur cette ligne : Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)

Manu

"MichD" <michdenis@hotmail.com> a écrit dans le message de news:
io7d31$97a$1@speranza.aioe.org...

Essaie ceci :

'-------------------------------------
Sub test()

Dim Rg As Range, C As Range
Dim Dic As Object, M As String, T()

With Worksheets("Feuil1")
Set Rg = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
Application.EnableEvents = False
Set Dic = CreateObject("Scripting.Dictionary")
For Each C In Rg
If C.Value = C.Offset(1) Then
If C.Offset(, 1) <> "" Then
If Not Dic.Exists(C.Offset(, 1).Value) Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
Else
If C.Offset(, 1) <> "" Then
If Not Dic.Exists("Emilie") Then
Dic.Add CStr(C.Offset(, 1)), C.Offset(, 1)
M = M & C.Offset(, 1).Value & ","
End If
End If
C.Offset(, 2) = Left(M, Len(M) - 1)
M = ""
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'-------------------------------------


MichD
--------------------------------------------

C'est plus que nickel, tjrs aussi epatant ! encore merci Mich Tjrs aussi
perfectionniste! Etonnant les connaissances que vous pouvez avoir !!!
J'appercierais tant comprendre ton code....Meme si Isabelle, toi et d'autres
essaient de nous initier, mais c'est franchement costaud. Mais bon, il nous
faut peut etre du temps.....
Merci de votre partage

Manu

Dans la procédure suggérée, ceci
Set Dic = CreateObject("Scripting.Dictionary")
ne provient pas directement du modèle objet "Excel-VBA"

C'est une bibliothèque que Windows utilise déjà dans son environnement.
Cela nous permet de l'utiliser sans charger la référence dans la fenêtre de
l'éditeur de code. (barre des menus / outils / référence / )

Dictionary est un objet appartenant à la bibliothèque "Scripting"

Library Scripting : Nom de la bibliothèque
'Pour Windows 64 bits:
C:WindowsSysWOW64scrrun.dll : Chemin & fichier responsable de cette bibliothèque
'Pour Windows 32 bits: C:WindowsSystem32scrrun.dll
'Nom descriptif de la référence à cocher à partir de la fenêtre des références
(barre des menus / outils / référence / )
Microsoft Scripting Runtime

Après avoir coché cette référence, toujours dans l'éditeur de code, tu affiches
la fenêtre de l'explorateur d'objets (raccourci clavier F2), dans la liste déroulante
"toutes les bibliothèques" tu sélectionnes "Scripting" et apparaît dans la fenêtre
du bas, le modèle objet de la bibliothèque. Dans la section de gauche, tu y trouveras
"Dictionary". Si tu cliques sur cette expression, apparaîtra à droite, les méthodes et
propriétés propres à cet objet.

Dans ton code, au lieu d'écrire
Dim Dic As Object
Tu pourras déclarer directement l'objet
Dim Dic As Scripting.Dictionary

Comme tu as coché la référence pour le projet VBA, l'expression "Scripting"
qui est la bibliothèque s'est ajoutée à la liste déroulante qui s'ouvre normalement
après avoir tapé le "As" dans la déclaration des variables.
De cette bibliothèque, on obtient toutes les propriétés et méthodes qu'elle contient.
Nul besoin de mémoriser cette information par coeur !

C'est la même bibliothèque qui contient : "FileSystemObject" utilise pour
boucler sur les répertoires et fichiers de l'explorateur Windows, copier, déplacer
ou supprimer des fichiers...En fait, tous les objets sont listés dans la fenêtre de
l'explorateur d'objets (F2)

Le reste de la procédure est un amalgame de si ....


MichD
--------------------------------------------
"MANU" a écrit dans le message de groupe de discussion : ioadvb$dr4$1@speranza.aioe.org...

C'est plus que nickel, tjrs aussi epatant ! encore merci Mich Tjrs aussi
perfectionniste! Etonnant les connaissances que vous pouvez avoir !!!
J'appercierais tant comprendre ton code....Meme si Isabelle, toi et d'autres
essaient de nous initier, mais c'est franchement costaud. Mais bon, il nous
faut peut etre du temps.....
Merci de votre partage

Manu

Bonsoir,
Aie, pas facile à comprendre, mais tout de meme j'ai pigé le but de prendre
sa propre bibilhotheque chez Excel, mais j'ai un gros soucis de
comprehension sur ce qu'est un Objet, une methode, une propriété...
Merci encore pour tout Mich

Manu

"MichD" <michdenis@hotmail.com> a écrit dans le message de news:
iobskh$cfj$1@speranza.aioe.org...

Dans la procédure suggérée, ceci
Set Dic = CreateObject("Scripting.Dictionary")
ne provient pas directement du modèle objet "Excel-VBA"

C'est une bibliothèque que Windows utilise déjà dans son environnement.
Cela nous permet de l'utiliser sans charger la référence dans la fenêtre
de
l'éditeur de code. (barre des menus / outils / référence / )

Dictionary est un objet appartenant à la bibliothèque "Scripting"

Library Scripting : Nom de la bibliothèque
'Pour Windows 64 bits:
C:WindowsSysWOW64scrrun.dll : Chemin & fichier responsable de cette
bibliothèque
'Pour Windows 32 bits: C:WindowsSystem32scrrun.dll
'Nom descriptif de la référence à cocher à partir de la fenêtre des
références
(barre des menus / outils / référence / )
Microsoft Scripting Runtime

Après avoir coché cette référence, toujours dans l'éditeur de code, tu
affiches
la fenêtre de l'explorateur d'objets (raccourci clavier F2), dans la liste
déroulante
"toutes les bibliothèques" tu sélectionnes "Scripting" et apparaît dans la
fenêtre
du bas, le modèle objet de la bibliothèque. Dans la section de gauche, tu
y trouveras
"Dictionary". Si tu cliques sur cette expression, apparaîtra à droite, les
méthodes et
propriétés propres à cet objet.

Dans ton code, au lieu d'écrire
Dim Dic As Object
Tu pourras déclarer directement l'objet
Dim Dic As Scripting.Dictionary

Comme tu as coché la référence pour le projet VBA, l'expression
"Scripting"
qui est la bibliothèque s'est ajoutée à la liste déroulante qui s'ouvre
normalement
après avoir tapé le "As" dans la déclaration des variables.
De cette bibliothèque, on obtient toutes les propriétés et méthodes
qu'elle contient.
Nul besoin de mémoriser cette information par coeur !

C'est la même bibliothèque qui contient : "FileSystemObject" utilise pour
boucler sur les répertoires et fichiers de l'explorateur Windows, copier,
déplacer
ou supprimer des fichiers...En fait, tous les objets sont listés dans la
fenêtre de
l'explorateur d'objets (F2)

Le reste de la procédure est un amalgame de si ....


MichD
--------------------------------------------
"MANU" a écrit dans le message de groupe de discussion :
ioadvb$dr4$1@speranza.aioe.org...

C'est plus que nickel, tjrs aussi epatant ! encore merci Mich Tjrs aussi
perfectionniste! Etonnant les connaissances que vous pouvez avoir !!!
J'appercierais tant comprendre ton code....Meme si Isabelle, toi et
d'autres
essaient de nous initier, mais c'est franchement costaud. Mais bon, il
nous
faut peut etre du temps.....
Merci de votre partage

Manu