Discussion :

[Mimosa777]

Bonjour à tous et à toutes,

je souhaite créer une procédure qui me permettrai de recupérer le contenu de plusieurs cellules ayant le meme nom d'usager dans une feuille et les recopier dans une seule cellule d'une autre feuille separe par une virgule par exemple.

Voici ce que j'ai comme exemple, je souhaiterai avec ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 
USAGER   |   TRANSIT
Alain       |    re1111
Alain       |    re112245
Julie        |    tr1111
Pierre      |    tr13456
Pierre      |    s01145657

avoir ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
 
USAGER   |   TRANSIT
Alain       |    re1111,re112245
Julie        |    tr1111
Pierre      |    tr13456,s01145657

J'ai trouvé cette fonction qui me crée bien ma cellule fusionné des autres cellules :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Private Sub CommandButton1_Click()
 
Dim Cpteur As Integer
Dim Chaine As String
Chaine = ""
 
For Cpteur = 1 To Feuil1.Range("a1").End(xlDown).Row
   Chaine = Chaine + CStr(Feuil1.Range("a" & Cpteur).Value) + ","
Next Cpteur
   Range("b2").Value = Chaine
End Sub

mais je n'arrive pas l'adapter parfaitement a ce que je vuex meme apres plusieurs tests. Je souhaiterai faire cette fusion lorsque USAGER est le même et copier le tout sur une nouvelle feuille.

Je vous remercie d'avance pour vos aides et propositions.

[fring]

Bonjour,

En supposant que les "USAGER" (colonne A) sont triés et que TRANSIT = colonne B, essayes ceci

Pour concatener les données sur la même feuille :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Sub recup_chaine()
Dim i As Integer
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(i, 1) = Cells(i - 1, 1) Then
Cells(i - 1, 2) = Cells(i - 1, 2) & ", " & Cells(i, 2)
Rows(i).Delete
End If
Next
End Sub

Pour concatener les données sur une autre feuille

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub recup_chaine()
Dim i As Integer, r As Integer
 
Sheets(2).Range("A2:B65535").ClearContents
 
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If i = 2 Then
        r = Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2).Row
        Sheets(2).Cells(r, 1) = Cells(i, 1)
        Sheets(2).Cells(r, 2) = Cells(i, 2)
        GoTo suite
    End If
    If Cells(i, 1) = Cells(i - 1, 1) Then
        r = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
        Sheets(2).Cells(r, 2) = Sheets(2).Cells(r, 2) & ", " & Cells(i, 2)
    Else
        r = Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2).Row
        Sheets(2).Cells(r, 1) = Cells(i, 1)
        Sheets(2).Cells(r, 2) = Cells(i, 2)
    End If
suite:
Next
 
End Sub

[Mimosa777]

Merci beaucoup Fring. ca marches tres bien avec ce code.

[Mimosa777]

Merci encore Fring. Cependant, les choses se sont un peu compliqué et j'essaie maintenant de reajuster ton code, mais j'ai un peu de misère a le faire fonctionner exactement et ton aide ou quiconque pouvant m'aider serait apprécié :

Voici un exemple de la table que je recois :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 
USAGER    | TRANSIT  |  ACCESS
alain            re2222           R
alain            re1223           R
alain            re1223           W 
julie             tg6567           R
julie             fg5656           W
daniel          fg5656            W
daniel          re4345            R

Grace a ton code, j'ai reussi a concatené cette table afin d'avoir tous les TRANSITS dans la meme cellule pour un USAGER ayant l'accès en R(lecture)

Voici mon code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub recup_chaine()
Dim i As Integer, r As Integer
 
Sheets(2).Range("A2:B65535").ClearContents
 
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If i = 2 Then
        r = Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2).Row
        Sheets(2).Cells(r, 1) = Cells(i, 1)
        Sheets(2).Cells(r, 2) = Cells(i, 2)
        GoTo suite
    End If
    If Cells(i, 1) = Cells(i - 1, 1) Then
        If Cells(i, 3).Value = "r" Then
        r = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
        Sheets(2).Cells(r, 2) = Sheets(2).Cells(r, 2) & "," & Cells(i, 2)
        End If
    Else
        r = Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2).Row
        Sheets(2).Cells(r, 1) = Cells(i, 1)
        Sheets(2).Cells(r, 2) = Cells(i, 2)
    End If
suite:
Next
 
End Sub

Ce code me retourne une feuille comme ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
 
USAGER        | TRANSIT-R         |  TRANSIT-W
alain               re2222,re1223           
julie                tg6567                   
daniel              re4345

Ce qui est merveilleux.
Mais mon probleme est que je n'arrive pas a faire la meme chose pour la colonne Transit-W. Meme en changeant le code de facon a ce qu'il retrace quand Cells(i,3)="w", il m'affiche pas les bonnes valeurs.

Je souhaiterai avoir ceci comme resultat final :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
 
USAGER        | TRANSIT-R         |  TRANSIT-W
alain               re2222,re1223          re1223
julie                tg6567                   fg5656
daniel              re4345                   fg5656

Merci encore pour l'aide. Tres apprécié !

[fring]

oula...ça se corse

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Sub recup_chaine()
Dim i As Integer, r As Integer
 
Sheets(2).Range("A2:C65535").ClearContents
 
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If i = 2 Then
        r = Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2).Row
        Sheets(2).Cells(r, 1) = Cells(i, 1)
            If Cells(i, 3) = "R" Then
                Sheets(2).Cells(r, 2) = Cells(i, 2)
            Else
                Sheets(2).Cells(r, 3) = Cells(i, 2)
            End If
        GoTo suite
    Else
        If Cells(i, 1) = Cells(i - 1, 1) Then
            r = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
                If Cells(i, 3) = "R" Then
                    If Sheets(2).Cells(r, 2) <> "" Then
                        Sheets(2).Cells(r, 2) = Sheets(2).Cells(r, 2) & ", " & Cells(i, 2)
                    Else
                        Sheets(2).Cells(r, 2) = Cells(i, 2)
                    End If
                Else
                    If Sheets(2).Cells(r, 3) <> "" Then
                        Sheets(2).Cells(r, 3) = Sheets(2).Cells(r, 3) & ", " & Cells(i, 2)
                    Else
                        Sheets(2).Cells(r, 3) = Cells(i, 2)
                    End If
                End If
        Else
            r = Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2).Row
            Sheets(2).Cells(r, 1) = Cells(i, 1)
                If Cells(i, 3) = "R" Then
                    Sheets(2).Cells(r, 2) = Cells(i, 2)
                Else
                    Sheets(2).Cells(r, 3) = Cells(i, 2)
                End If
        End If
    End If
suite:
Next
 
End Sub

[Mimosa777]

Fring, tu es genial. Je te remercie enormement pour le temps que tu as consacre a m'aider. En y apportant quelques retouches a ton magnifique code, j'ai reussi a ajouter une 4eme condition sur une 4eme colonne qui devait etre regoupé aussi. Assez corsé j'avoue.

Milles merci a toi et a ce magnifique Forum !!!

Pour ceux a qui cela peut aider un jour, voici l'objectif de départ et le resultat attendu. Je possède une feuille tel que :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
 
USAGER    | TRANSIT  |  ACCESS    |   GROUPE
10099	TRTR040005	W	GRP10
17130	TRTR040005	W	GRP10
17130	TRTR040010	W	GRP10
19446	TRTR040010	W	GRP10
19446	TRTR020050	W	GRP10
19446	TOTTRES  	R	GRP10
19446	TRTR040010	W	GRP18
19446	TRTR020050	W	GRP18
19446	TOTTRES 	R	GRP18

et voici le resultat souhaité :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
 
USAGER    | TRANSIT-R          |  TRANSIT-W                                     | GROUPE
10099	                        TRTR040005	                                   GRP10
17130		                TRTR040005, TRTR040010	                            GRP10
19446	    TOTTRES, TOTTRES     TRTR040010, TRTR020050, TRTR040010, TRTR020050	   GRP10, GRP18

et voici le code pour realiser le tout (merci encore a Fring)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
 
Sub recup_chaine()
Dim i As Integer, r As Integer
 
Sheets(2).Range("A2:C65535").ClearContents
 
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If i = 2 Then
        r = Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2).Row
        Sheets(2).Cells(r, 1) = Cells(i, 1)
        Sheets(2).Cells(r, 4) = Cells(i, 4)
            If Cells(i, 3) = "R" Then
                Sheets(2).Cells(r, 2) = Cells(i, 2)
            Else
                Sheets(2).Cells(r, 3) = Cells(i, 2)
            End If
        GoTo suite
    Else
        If Cells(i, 1) = Cells(i - 1, 1) Then
            r = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
                If Cells(i, 3) = "R" Then
                    If Sheets(2).Cells(r, 2) <> "" Then
                        Sheets(2).Cells(r, 2) = Sheets(2).Cells(r, 2) & ", " & Cells(i, 2)
                        Sheets(2).Cells(r, 4) = Sheets(2).Cells(r, 4) & ", " & Cells(i, 4)
                    Else
                        Sheets(2).Cells(r, 2) = Cells(i, 2)
                    End If
                Else
                    If Sheets(2).Cells(r, 3) <> "" Then
                        Sheets(2).Cells(r, 3) = Sheets(2).Cells(r, 3) & ", " & Cells(i, 2)
                     Else
                        Sheets(2).Cells(r, 3) = Cells(i, 2)
                    End If
                End If
        Else
            r = Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2).Row
            Sheets(2).Cells(r, 1) = Cells(i, 1)
            Sheets(2).Cells(r, 4) = Cells(i, 4)
                If Cells(i, 3) = "R" Then
                    Sheets(2).Cells(r, 2) = Cells(i, 2)
                Else
                    Sheets(2).Cells(r, 3) = Cells(i, 2)
                End If
        End If
    End If
suite:
Next
 
End Sub