Regrouper des doublons

Bonjour à tous,

j'ai bien lu ce topic : https://forum.excel-pratique.com/viewtopic.php?forum_uri=excel&t=27550&start= qui correspond parfaitement à ma demande mais je n'arrive pas a adapter la macro pour plusieurs colonnes à dupliquer.

En effet, j'ai un tableau avec des doublons que je souhaiterai regrouper pour ne plus avoir de doublon tout en conservant l'information associée au doublon.

Exemple :

ID_CHANES Code_Veg Code_N2000 Part_Poly Typi Repres Interpat Etatcons Dyna

53413 3 0 70 0 0 0 2

53413 141 6430 20 0 0 0 2

53413 33 3270 10 0 0 0 2

ID_CHANES Code_Veg Code_N2000 Part_Poly Typi Repres Interpat Etatcons Dyna Code_Veg2 Code_N20002 Part_Poly2 Typi2 Repres2 Interpat2 Etatcons2 Dyna2 Code_Veg3 Code_N20003 Part_Poly3 Typi3 Repres3 Interpat3 Etatcons3 Dyna3

53413 3 0 70 0 0 0 2 141 6430 20 0 0 0 2 33 3270 10 0 0 0 2

Quelqu'un pourrait il m'apporter de l'aide svp ?

Je vous joint mon tableau :

Merci beaucoup,

bonne journée.

Bonjour,

Avec une colonne supp et un tcd

https://www.cjoint.com/c/HBupHml7aEl

Cdlmnt

Bonjour à tous

Une variante à tester.

Bye !

Bonsoir à tous,

A tester restitution en feuil1 préalablement créée

Option Explicit
Sub Regroupement()
Dim a, w(), i As Long, j As Long, n As Long, col As Byte, nbCol As Byte, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("donnees_habitats_etat_conservat").Cells(1).CurrentRegion.Value2
    col = UBound(a, 2): nbCol = col - 1: n = 1
    For i = 2 To UBound(a, 1)
        If Not dico.exists(a(i, 1)) Then
            n = n + 1: dico(a(i, 1)) = VBA.Array(n, col)
            For j = 1 To col
                a(n, j) = a(i, j)
            Next
        Else
            w = dico(a(i, 1)): w(1) = w(1) + nbCol
            If UBound(a, 2) < w(1) Then
                ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
            End If
            For j = 1 To nbCol
                a(w(0), w(1) - nbCol + j) = a(i, j + 1)
            Next
            dico(a(i, 1)) = w
        End If
    Next
    If UBound(a, 2) > col Then
        For j = col + 1 To col + nbCol
            a(1, j) = a(1, j - col + 1) & "_2"
        Next
    End If
    'Restitution
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Cells(1).Resize(n, UBound(a, 2))
        .CurrentRegion.Clear
        For j = 3 To UBound(a, 2) Step nbCol
            .Columns(j).NumberFormat = "@"
        Next
        .Value = a
        With .Font
            .Name = "calibri"
            .Size = 10
        End With
        .VerticalAlignment = xlCenter
        .Borders(xlInsideVertical).Weight = xlThin
        .BorderAround Weight:=xlThin
        With .Rows(1)
            .Font.Size = 11
            .Interior.ColorIndex = 43
            .BorderAround Weight:=xlThin
        End With
        If UBound(a, 2) > col + nbCol Then
            With .Offset(, col).Resize(1, nbCol)
                .AutoFill .Resize(, UBound(a, 2) - col)
            End With
        End If
        .Columns.AutoFit
        .Parent.Select
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

c'est super ça fonctionne merci beaucoup !!