Extraction de toutes les valeurs uniques depuis une sélection de cellules

Bonsoir,

Je cherche à réaliser, en VBA j'imagine, le décompte et l'extraction de chacune des valeurs uniques présentes dans une sélection de cellules. Autrement dit, si j'ai dans deux cellules : "rouge vert" et "bleu rouge", je souhaiterais extraire dans une colonne "rouge", "vert", "bleu".

J'espère que c'est assez clair. Je joins un ficher d'exemple le cas échéant.

En n'oubliant pas de vous remercier par avance.

Bonsoir,

voici un code :

Sub LRD()
    Dim tablo, MonDico As New Scripting.Dictionary
    tablo = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    For i = 1 To UBound(tablo)
        tablo2 = Split(tablo(i, 1), " ")
        For j = 0 To UBound(tablo2)
            tablo3 = Split(tablo2(j), "'")
            For k = 0 To UBound(tablo3)
                If Not MonDico.Exists(tablo3(k)) Then
                    MonDico.Add tablo3(k), tablo3(k)
                End If
            Next k
        Next j
    Next i
    Range("E2").Resize(MonDico.Count) = Application.Transpose(MonDico.Items)
End Sub

Il faut activer la référence aux Microsoft Scripting Rnutime sous VBA.
Les dictionnaires n'acceptent pas les doublons.

Seul le " d' " n'est pas géré comme vous le demandez...

@ bientôt

LouReeD

Bonsoir le fil, bonsoir le forum,

Je ne comprends pourquoi faire si simple alors qu'on peut faire tellement plus compliqué !... Et je le prouve :

Option Explicit

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim NE As Byte 'déclare la varaible NE (Nombre d'Espaces)
Dim NA As Byte 'déclare la varaible NA (Nombre d'Apostrophes)
Dim TE() As Variant 'déclare la variable TE (Tableau des Espaces)
Dim TA() As Variant 'déclare la variable TA (Tableau des Apostrophes)

Set O = Worksheets("Feuil1") 'définit l'onglet O
TV = O.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
O.Range("C1").CurrentRegion.Offset(1, 0).ClearContents 'efface les ancienne valeurs
Set D = CreateObject("Scripting.Dictionary") 'définit la dictionnaire D
For I = 2 To UBound(TV) 'boucle 1 : sur toutes les lignes I du tableau des valeur TV (en partant de la seconde)
    NE = UBound(Split(TV(I, 1), " ")) 'définit le nombre d'espace NE de la donnée ligne I colonne 1 de TV
    If NE > 0 Then 'condition : si NE est supérieure à zéro (plusieurs mots)
        For J = 0 To NE 'boucle 2 : de 0 à NE (boucle sur chaque espace)
            K = K + 1 'incrémente K
            ReDim Preserve TE(K) 'redimensionne le tableau des espaces TE (K lignes)
            'récupère dans la ligne K de TE la partie du mot avant l'espace pour J=0, après le premier espace pour J=1, après le second espace pour J=2, etc.
            TE(K) = Split(TV(I, 1), " ")(J)
        Next J 'prochain espace de la boucle
    Else 'sinon (NE est égqle à zéro (un seul mot)
        K = K + 1 'incrémente K
        ReDim Preserve TE(K) 'redimensionne le tableau des espaces TE (K lignes)
        TE(K) = TV(I, I) 'récupère le mot dans la ligne K de TE
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
'à ce stade on a un tabeau TE avec chaque mot séparé par un espace mais l'apostrophe n'est pas séparée

K = 0 'initialise la variable K
For I = 1 To UBound(TE) 'boucle 1 : sur tous les mots de TE
    NA = UBound(Split(TE(I), "'")) 'définit le nombre d'espace NE de le mot TE(I)
    If NA > 0 Then 'condition si le nombre d'apostrophes est supérieur à zéro
        For J = 0 To NA 'boucle 2 : de 0 à NA (boucle sur chaque apostrohe)
            K = K + 1 'incrémente K
            ReDim Preserve TA(K) 'redimensionne le tableau des apostrophes TA (K lignes)
            'récupère dans la ligne K de TA la partie du mot avant l'apostrophe pour J=0, après le premier apstrophe pour J=1, etc.
            'en rajoutant une apostrophe quand J est égale à zéro (pour "d'" et pas "d" tout seul)
            TA(K) = IIf(J = 0, Split(TE(I), "'")(J) & "'", Split(TE(I), "'")(J))
        Next J 'procheine apostrophe de la boucle
    Else 'sinon (pas d'apostrophe)
        K = K + 1 'incrémente K
        ReDim Preserve TA(K) 'redimensionne le tableau des apostrophes TA (K lignes)
        TA(K) = TE(I) 'récupère le mot TA(I) dans la ligne K de TA
    End If 'fin de la condition
Next I 'prochain mot de la boucle 1
'à ce stade on a un tabeau TA avec chaque mot séparé par un espace ainsi que les mots séparées par l'apostrophe mais il y a des doublons

For I = 1 To UBound(TA) 'boucles sur tous les mots de TA
    D(TA(I)) = "" 'alimente le dictionnaire D
Next I 'prochain mot de la boucle
'renvoie dasn C2 redimentionnée le tableau transposé des éléments du dictionnaire D sans doublons (les clés)
O.Range("C2").Resize(UBound(D.Keys), 1) = Application.Transpose(D.Keys)
End Sub

J'm'en fous LouReed ! Même pas mal... Arghhhh....

Bonjour,
Une proposition Power Query.
Cdlt.

Bonjour,

Ha PQ (?) , ça me laisse songeur.... Il faut vraiment que je m'y mette , en plus c'est par ordre alphabétique !

@ bientôt

LouReeD

Merci LouReeD, ThauThème et Jean-Eric,

Je vais essayer tout cela et je n'hésite pas à solliciter votre éclairage si je m'égare dans l'ombre!

Un grand merci à vous,

Bonjour

Merci de vos remerciements !

Prtso je prendrais le code de ThauThème de par sa simplicité de comprehension par la presence des commentaires ! Bien qu'il y en ait un qui soit erroné : celui de l'attribution de NA...

@ bientôt

LouReeD