Suppression de mot en double sur une cellule

Bonjour à tous,

Je cherche en vain une solution à mon problème.

Je possède un fichier exel de 25 000 lignes.

Sur mon fichier il y a un grand nombre de cellule ou plusieurs mot ou phrases se répètent en double ou même voir en triple.

La fonction supprimer les doublon ne marche que si il existe plusieurs cellule avec les même mot mais dans mon cas il s'agit de plusieurs même mot dans la même cellule et ceux sur plusieurs centaine de cellule différentes.

Exemple :

Ce que je possède :

Pare chocs avant bmw e46, à peindre convient pour les modèles de 2000 à 2003 à peindre sans gicleur lave phare à peindre

Ce que j'aimerais comme résultat :

Pare chocs avant bmw e46, à peindre convient pour les modèles de 2000 à 2003 sans gicleur lave phare

Comme vous le constatez il y a 3 fois les mot "à peindre" et je n'aimerais que en conserver un seul.

Est-ce que qu'elqun d'(entre vous aurais une solution pour m'aider ??

Je vous remercie par avance de votre attention et j'espère à bientot.

Steve

Bonsoir,

2 exemples : 1 fonction personnalisée & 1 macro à adapter.

A te lire. Cdlt

Public Function SplitCollection1(Cellule As String) As String
Dim nbEspaces As String
Dim i As Byte
Dim c, d
Dim monDico
Dim temp
    temp = ""
    nbEspaces = Len(Cellule) - Len(Application.WorksheetFunction.Substitute(Cellule, " ", ""))
    Set monDico = CreateObject("Scripting.Dictionary")
    For i = 0 To nbEspaces
        c = Split(Cellule, " ")(i)
        If Not monDico.Exists(c) Then monDico.Add c, c
    Next

    For Each d In monDico.items
        temp = temp & " " & d
    Next

    SplitCollection1 = Trim(temp)
End Function

Public Sub SplitCollection()
Dim nbEspaces As String
Dim i As Byte
Dim c, d
Dim monDico
Dim temp
    'temp = ""
    [A1].Select
    nbEspaces = Len(ActiveCell) - Len(Application.WorksheetFunction.Substitute(ActiveCell, " ", ""))
    Set monDico = CreateObject("Scripting.Dictionary")
    For i = 0 To nbEspaces
        c = Split(ActiveCell.Value, " ")(i)
        If Not monDico.Exists(c) Then monDico.Add c, c
    Next

    For Each d In monDico.items
        temp = temp & " " & d
    Next
    [A5] = Trim(temp)
End Sub