Valeur unique par colonne avec ces valeur

Private Sub CommandButton1_Click()
Dim i&, j&, K As Variant, T As Variant
Dim DGen As Object

Set DGen = CreateObject("scripting.dictionary")

With Sheets("Feuil3")
    T = .Range(.Cells(1, 2), .Cells(.Cells(.Rows.Count, 1).End(3).Row, .Cells(1, .Columns.Count).End(1).Column - 1))
End With

For j = LBound(T, 2) To UBound(T, 2)
    If Not DGen.exists(T(1, j)) Then Set DGen(T(1, j)) = CreateObject("scripting.dictionary")
    For i = LBound(T, 1) + 1 To UBound(T, 1)
        DGen(T(1, j))(T(i, j)) = DGen(T(1, j))(T(i, j)) + 1
    Next i
Next j

i = 1
With Sheets("Feuil2")
    .Cells.ClearContents
    For Each K In DGen.keys
        .Cells(1, i) = K
        .Cells(2, i).Resize(DGen(K).Count, 1) = Application.Transpose(DGen(K).keys)
        .Cells(2, i + 1).Resize(DGen(K).Count, 1) = Application.Transpose(DGen(K).items)
        i = i + 3
    Next K
    .Columns.AutoFit
    .Activate
End With

End Sub

Private Sub CommandButton1_Click()
Dim i&, j&, K As Variant, T As Variant
Dim DGen As Object

Set DGen = CreateObject("scripting.dictionary")

With Sheets("Feuil3")
    T = .Range(.Cells(1, 2), .Cells(.Cells(.Rows.Count, 1).End(3).Row, .Cells(1, .Columns.Count).End(1).Column - 1))
End With

For j = LBound(T, 2) To UBound(T, 2)
    If Not DGen.exists(T(1, j)) Then Set DGen(T(1, j)) = CreateObject("scripting.dictionary")
    For i = LBound(T, 1) + 1 To UBound(T, 1)
        If T(i, j) <> "" Then DGen(T(1, j))(T(i, j)) = DGen(T(1, j))(T(i, j)) + 1
    Next i
Next j

i = 1
With Sheets("Feuil2")
    .Cells.Clear
    For Each K In DGen.keys
        .Cells(1, i) = K
        .Cells(1, i + 1) = "Nb_" & K
        .Cells(2, i).Resize(DGen(K).Count, 1) = Application.Transpose(DGen(K).keys)
        .Cells(2, i + 1).Resize(DGen(K).Count, 1) = Application.Transpose(DGen(K).items)
        With .ListObjects.Add(xlSrcRange, .Range(.Cells(1, i), .Cells(1, i + 1)).Resize(DGen(K).Count + 1, 2), , xlYes)
            .Name = "Tableau" & i
            .TableStyle = "TableStyleMedium4"
            .ShowTotals = True
        End With
        i = i + 3
    Next K
    .Columns.AutoFit
    .Activate
End With

End Sub