VBA Collections pour liste sans doublons

Bonjour à tous,

je souhaite créer une collection pour avoir une liste sans doublons (grâce à la clé). Cependant, mon conde s'arrête dès lors que un doublon arrive. Pourriez vous m'aider ?

 Sub liste_sans_doublon()

Dim Tablo As Collection
Dim cell As Range
Dim LineP As Integer
Dim Item

Set range_cac40 = SH_EuroIndex.Range(Range("Euro_Index_Cell_CAC_40_Noms").Offset(1), Range("Euro_Index_Cell_CAC_40_Noms").End(xlDown))
Set range_estx50 = SH_EuroIndex.Range(Range("Euro_Index_Cell_ESTX50_Noms").Offset(1), Range("Euro_Index_Cell_ESTX50_Noms").End(xlDown))

Set Tablo = New Collection
For Each cell In Union(range_cac40.Cells, range_estx50.Cells)
Tablo.Add cell.Value, cell.Value
Next cell

End Sub

Bonjour

Il est toujours plus simple de comprendre avec un fichier EXCEL anonymisé complété par des explications exhaustives

Slts

Bonjour,

ci-dessous code :

Sub liste_triée_sans_doublon()

    Dim Tablo As New Collection
    Dim range_cac40 As Range, range_estx50 As Range, cell As Range
    Dim i As Integer, j As Integer, clé1 As Variant, clé2 As Variant
    Dim tb(): tb = Array()
    Dim liste: liste = Array()

    '// définition plages à traiter
    Set range_cac40 = SH_EuroIndex.Range(Range("Euro_Index_Cell_CAC_40_Noms").Offset(1), Range("Euro_Index_Cell_CAC_40_Noms").End(xlDown))
    Set range_estx50 = SH_EuroIndex.Range(Range("Euro_Index_Cell_ESTX50_Noms").Offset(1), Range("Euro_Index_Cell_ESTX50_Noms").End(xlDown))

    '// chargement valeurs dans un tableau à une dimension
    For Each cell In Union(range_cac40.Cells, range_estx50.Cells)
        ReDim Preserve tb(i): tb(i) = cell.Value
        i = i + 1
    Next cell

    '// création liste triée sans doublons
    For i = 0 To UBound(tb)
        clé1 = tb(i)
        j = 0
        For Each clé2 In Tablo
            j = j + 1
            If clé1 < clé2 Then
                'pas de doublons et postionnement selon ordre croissant de la clé
                On Error Resume Next
                Tablo.Add Item:=clé1, Key:=CStr(clé1), Before:=j
                On Error GoTo 0
                Exit For
            End If
        Next clé2
        If clé1 > clé2 Then
            On Error Resume Next
            Tablo.Add Item:=clé1, Key:=CStr(clé1)
            On Error GoTo 0
        End If
    Next i

    '// assignation de la liste
    i = 0
    For Each clé1 In Tablo
        If clé1 <> Empty Then
            ReDim Preserve liste(i): liste(i) = clé1
            i = i + 1
        End If
    Next clé1

    Range("ici").Offset(1).Resize(Tablo.Count).Value = Application.Transpose(liste)

End Sub