[XL-2003] Trier et concaténer des groupes [Résolu]

[mikkk]

Bonjour,

J'ai un fichier qui ressemble à ceci :

toto | groupe 1
toto | groupe 2
toto | groupe 3
tata | groupe 2
tata | groupe 4
tutu | groupe 1
tete | groupe 4

Je voudrais en fait trier la première colonne sans doublons mais sans perdre les informations de la deuxième colonne. En fait je souhaiterais obtenir ce résultat :

toto | groupe 1, groupe 2, groupe 3
tata | groupe 2, groupe 4
tutu | groupe 1
tete | groupe 4

Etant donné que je débute et que j'ai un peu de mal à imaginer un algo capable de faire cette opération, j'esperais avoir un peu d'aide de votre part. Ou au moins une piste pour m'aider à écrire une formule sachant que mon fichier contient plus de 6000 lignes.

Merci d'avance pour vos lumières.

[mercatog]

Code :

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
Sub Test()
Dim LastLig As Long, i As Long, j As Long, k As Long
Dim Tb
Dim Res() As String, S As String
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")                        'A adapter
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    With .Range("A2:B" & LastLig)
        Tb = .Value
        .ClearContents
    End With
    For i = 1 To LastLig - 2
        If Not IsEmpty(Tb(i, 1)) Then
            For j = i + 1 To LastLig - 1
                If Tb(i, 1) = Tb(j, 1) Then
                    S = S & ", " & Tb(j, 2)
                    Tb(j, 1) = Empty
                End If
            Next j
            k = k + 1
            ReDim Preserve Res(1 To 2, 1 To k)
            Res(1, k) = Tb(i, 1)
            Res(2, k) = Tb(i, 2) & ", " & Mid(S, 3)
            S = ""
        End If
    Next i
    .Range("A2").Resize(2, k) = Application.Transpose(Res)
End With
End Sub

[mikkk]

Merci pour cette réponse très rapide.
J'ai essayé ce code malheureusement cela ne fonctionne pas, j'obtiens ce résultat :

toto | groupe 1
toto | groupe 2, groupe 3 | #N/A
tata | groupe 2, groupe 4 | #N/A

J'essaie de comprendre le fonctionnement de ton code mais ce n'est pas simple. En tout cas cela peut être une piste.

[Daniel.C]

Bonjour,

Essaie :

Code :

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
Sub test()
    Dim c As Range, Dico As Object
    Dim Ligne As Long, Col As Integer, Tabl(1000, 50) As String, Ctr As Integer
    Set Dico = CreateObject("Scripting.Dictionary")
    Ctr = -1
    With Sheets("Feuil1")
        For Each c In .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp))
            If Not Dico.exists(c.Value) Then
                Dico.Add c.Value, c.Value
                Ctr = Ctr + 1
                Tabl(Ctr, 0) = c.Value
            End If
            Col = Application.Match(c.Value, Dico.items, 0) - 1
            For i = 0 To 100
                If Tabl(Ctr, i) = "" Then
                    Tabl(Ctr, i) = c.Offset(, 1).Value
                    Exit For
                End If
            Next i
        Next c
    End With
    With Sheets("Feuil2")
        For i = 0 To 1000
            If Tabl(i, 0) = "" Then Exit For
            .Cells(i + 1, 1) = Tabl(i, 0)
            For Col = 0 To 100
                If Tabl(i, Col) = "" Then Exit For
                .Cells(i + 1, Col + 1) = Tabl(i, Col)
            Next Col
        Next i
    End With
End Sub

[mercatog]

Remplace la ligne 28 par

Code :

    .Range("A2").Resize(2, k - 1) = Application.Transpose(Res)

J'ai considéré que les données commencent en A2:B2

[mikkk]

Merci pour vos réponses, je n'attendais pas un code déjà tout fait, ça fait d'autant plus plaisir. C'est tout de même un peu plus compliqué que ce que j'aurais imaginé mais je vais tâcher de comprendre un peu comment ça fonctionne.
Vos solutions fonctionnent super bien en tout cas, merci à vous.
Vous venez de sauver une vie