Option Explicit
Sub Macro1()
Dim nbRows As Long
Dim nbCols As Integer
Dim x As Integer, y As Long
Dim nbCells As Long
Dim Pointeur As Long
' On copie la feuille1 dans la feuille 2
Cells.Select
Range("A20").Activate
Selection.Copy
Sheets("Feuil2").Select
Cells.Select
ActiveSheet.Paste
Worksheets("Feuil2").Select
' On calcule le nombre de colonnes du tableau
nbCols = ActiveSheet.UsedRange.Columns.Count
' On recopie les colonnes 2 à nbcols dans la colonne 1
For x = 2 To nbCols
Pointeur = Cells(Rows.Count, 1).End(xlUp).Row
nbCells = Cells(Rows.Count, x).End(xlUp).Row + 1
For y = 1 To nbCells
Cells(y + Pointeur, 1) = Cells(y, x)
Next y
Next x
' On supprime les cellules vides s'il y en a
Pointeur = Cells(Rows.Count, 1).End(xlUp).Row
For y = Pointeur To 1 Step -1
If Cells(y, 1) = "" Then
Rows(y).Select
Selection.Delete Shift:=xlUp
End If
Next y
' On ne garde que la colonne 1
For x = nbCols To 2 Step -1
Columns(x).Select
Selection.Delete Shift:=xlToLeft
Next x
' On trie la feuille sur la colonne 1
Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' et on détruit les lignes contenant des valeurs non répétées
For y = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(y, 1) = Cells(y - 1, 1) Or Cells(y, 1) = Cells(y + 1, 1) Then
Else
Rows(y).Select
Selection.Delete Shift:=xlUp
End If
Next y
If Cells(1, 1) <> Cells(2, 1) Then
Rows(1).Select
Selection.Delete Shift:=xlUp
End If
' Il ne reste que les doublons
End Sub