XL 2016 Comment supprimer des mots en double à l'intérieur d'une cellule en masse

[youns33]

Bonjour à tous,

Désolé je n'ai pas trouvé de réponse dans le forum.

Voila j'ai un énorme fichier de 120000 lignes, avec des titres de produits en colonne A, et dans certaines cellule de ma colonne titre j'ai des mots en double, triple.., exemple avec ces 2 titres de produit en A1 et A2:

A1 >>> Endoscope numérique 720P Waterproof USB Endoscope Caméra d'inspection de tube de serpent avec 6 LED

A2 >>> Tablette numérique Android tablette Full HD tablette

Existe t'il une formule excel à mettre en B1 qui me permettrai de supprimer les mots en double, ou triple ou quadriple etc...de la cellule A1 et de ne garder que le 1er des 2 ou des 3 etc (ici en l’occurrence "Endoscope" et "de"), et que je pourrais ensuite dupliquer jusqu'en bas de mes 120000 lignes?

La casse n'est pas respecté, Endoscope et endoscope sont identique.

Merci d'avance

 

[eriiic]

Bonjour,

réponse ici : https://forum.excel-pratique.com/excel/supprimer-les-mots-en-double-d-une-cellule-t99876.html
eric

 

[youns33]

Salut, oui j'avais posté sur les 2 forums, je ne pensais pas que la communauté serait aussi réactive 🙂 Merci

 

[job75]

Bonjour youns33 alias yptsba, salut eriiiic,

J'ai testé la méthode donnée sur l'autre forum avec 120 000 lignes en utilisant cette fonction :

Function Mots_uniques$(x)
Dim ub%, i%, t$, j%
x = Split(x)
ub = UBound(x)
For i = 0 To ub
  t = UCase(x(i))
  For j = i + 1 To ub - 1
     If UCase(x(j)) = t Then x(j) = ""
Next j, i
Mots_uniques = Application.WorksheetFunction.Trim(Join(x)) 'SUPPRESPACE
End Function

Le recalcul des 120 000 formules en colonne B se fait en 7,2 secondes chez moi.

J'ai voulu voir ce qu'on obtient avec le Dictionary :

Dim d As Object 'mémorise la variable (fait gagner beaucoup de temps)

Function Mots_uniques$(x)
Dim i%, t$
If d Is Nothing Then Set d = CreateObject("Scripting.Dictionary") Else d.RemoveAll
x = Split(x)
For i = 0 To UBound(x)
  t = UCase(x(i))
  If d.exists(t) Then x(i) = "" Else d(t) = ""
Next
Mots_uniques = Application.WorksheetFunction.Trim(Join(x)) 'SUPPRESPACE
End Function

Eh bien le recalcul se fait en 7,4 secondes, je pensais que ce serait plus rapide.

Nota : avec d.CompareMode = vbTextCompare pour ignorer la casse c'est un peu moins rapide.

Fichiers joints, cliquez sur le bouton "Test".

A+

 

[job75]

Re,

La fonction peut être utilisée dans une Worksheet_Change :

Private Sub Worksheet_Change(ByVal r As Range)
Set r = Intersect(r, Range("A2:B" & Rows.Count), UsedRange)
If r Is Nothing Then Exit Sub
Dim t#
t = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each r In Intersect(r.EntireRow, [A:B]).Areas
  r.Columns(2) = "=Mots_uniques(RC[-1])"
  r.Columns(2) = r.Columns(2).Value 'supprime les formules
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
If Timer - t > 0.1 Then MsgBox "Durée d'exécution " & Format(Timer - t, "0.00 \s")
End Sub

Fichiers (2).

A+

 

[youns33]

Salut et merci Job75 pour tes réponses, ça fonctionne très bien mêmes avec plus de 120000 lignes et c'est très rapide ++++++
Par contre j'avoue ne pas bien comprendre les différences entre tous les fichiers que tu as proposé...