Trier les doublons

Bonjour,

je souhaiterais pouvoir trier les doublons...

imaginer des prénoms doublés voir triplés et même plus dans des colonnes différentes et lignes différentes

Je souhaiterais les trier en commençant par la liste des prénoms de la première colonne et en finissant par le dernier prénom de la dernière colonne si il n'a pas été déjà listé

Exemple:

Feuil 1

j'obtiendrais

Feuil2

est-ce possible?

d'avance merci pour toutes propositions

Bonne journée.

bonjour,

une proposition (via macro)

Sub aargh()
    Dim t(), dl, dc, j, i, nb, ctr, prenom, ligne
    Dim ws1, ws2, dict

    Set ws1 = Sheets("feuil1")
    Set ws2 = Sheets("feuil2")
    ws2.Cells.Delete
    ws1.Rows(1).Copy ws2.Range("A1")
    With ws1
        dl = .UsedRange.Rows.Count
        dc = .UsedRange.Columns.Count
        ReDim t(1 To dl * dc, 1 To dc)
        Set dict = CreateObject("scripting.dictionary")
        For j = 1 To dc
            For i = 2 To dl
                prenom = .Cells(i, j)
                If prenom <> "" Then
                    nb = Application.CountIf(.UsedRange, prenom)
                    If nb > 1 Then
                        If dict.exists(prenom) Then
                            ligne = dict(prenom)
                        Else
                            ctr = ctr + 1
                            dict(prenom) = ctr
                            ligne = ctr
                        End If
                        t(ligne, j) = prenom
                    End If
                End If
            Next i
        Next j
    End With
    ws2.Range("A2").Resize(ctr, dc) = t
End Sub

Et si je souhaite conserver le Format de la cellule?...

Non je vais arrêté là!

c'est Top!

Merci!! c'est exactement ce que je cherchais...

Bonne soirée!

bonsoir,

en gardant le format des cellules (moins performant)

Sub aargh()
    Dim t(), dl, dc, j, i, nb, ctr, prenom, ligne
    Dim ws1, ws2, dict
    Application.ScreenUpdating = False
    Set ws1 = Sheets("feuil1")
    Set ws2 = Sheets("feuil2")
    ws2.Cells.Delete
    ws1.Rows(1).Copy ws2.Range("A1")
    With ws1
        dl = .UsedRange.Rows.Count
        dc = .UsedRange.Columns.Count
        ReDim t(1 To dl * dc, 1 To dc)
        Set dict = CreateObject("scripting.dictionary")
        ctr = 1
        For j = 1 To dc
            For i = 2 To dl
                prenom = .Cells(i, j)
                If prenom <> "" Then
                    nb = Application.CountIf(.UsedRange, prenom)
                    If nb > 1 Then
                        If dict.exists(prenom) Then
                            ligne = dict(prenom)
                        Else
                            ctr = ctr + 1
                            dict(prenom) = ctr
                            ligne = ctr
                        End If
                        ws1.Cells(i, j).Copy ws2.Cells(ligne, j)
                    End If
                End If
            Next i
        Next j
    End With
    Application.ScreenUpdating = True
End Sub

merci!