Fusionner contenu de x lignes si le contenu de la 1ère colonne est identique

[zebu14]

Bonjour à tous,

J'ai parcouru le forum à la recherches de macros VBA qui me permettraient d'arriver à mes fins.
Il y a des nombreux sujets qui traitent de la fusion de lignes sans pertes de données, mais je ne suis pas parvenu à adapter le code VBA pour obtenir ce dont j'ai besoin.

J'ai un tableau excel contenant plusieurs lignes.
Chaque ligne est rattachée à un code (et chaque code est rattaché à un nom)
Je voudrais que les lignes qui ont la même valeur dans la colonne "Code" (et donc "Nom" également) soient fusionnées dans une seule et même ligne, avec l'ensemble des données de chaque colonne (et un seul code et nom dans les deux premières colonnes).

Voir le fichier en pièce-jointe pour un exemple de ce que je cherche à obtenir.

Merci pour votre aide.

 

[job75]

Bonjour zebu14, bienvenue sur XLD,

Voyez le fichier joint et cette macro dans le code de la feuille "Résultat" (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_Activate()
Dim ncol%, tablo, resu(), d As Object, i&, x$, n&, nn&, j%
With Feuil1.[A1].CurrentRegion 'à adapter
    ncol = .Columns.Count
    If ncol < 2 Then ncol = 2 'au moins 2 colonnes
    tablo = .Resize(, ncol) 'matrice, plus rapide
End With
ReDim resu(1 To UBound(tablo), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(tablo)
    x = tablo(i, 1) & Chr(1) & tablo(i, 2)
    If Not d.exists(x) Then
        n = n + 1
        d(x) = n 'mémorise la ligne
        resu(n, 1) = tablo(i, 1)
        resu(n, 2) = tablo(i, 2)
    End If
    nn = d(x)
    For j = 3 To ncol
        resu(nn, j) = IIf(resu(nn, j) = "", "", resu(nn, j) & vbLf) & tablo(i, j)
Next j, i
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A1] 'cellule à adapter
    With .Resize(n, ncol)
        .Value = resu
        .ColumnWidth = 255
        .WrapText = True 'renvoi à la ligne
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .EntireColumn.AutoFit 'ajustement largeur
    End With
    .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ en dessous
End With
With UsedRange: End With 'actualise les barres de défilement
End Sub

La macro se déclenche quand on active la feuille.

A+

 

[zebu14]

C'est parfait, merci beaucoup !
Il ne me reste plus qu'à comprendre les subtilités du code.

Merci encore.