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

youns33

XLDnaute Nouveau
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
 

job75

XLDnaute Barbatruc
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 :
Code:
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 :
Code:
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+
 

Pièces jointes

  • Mots_uniques sans Dictionary(1).xlsm
    1.8 MB · Affichages: 40
  • Mots_uniques avec Dictionary(1).xlsm
    1.8 MB · Affichages: 46
Dernière édition:

job75

XLDnaute Barbatruc
Re,

La fonction peut être utilisée dans une Worksheet_Change :
Code:
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+
 

Pièces jointes

  • Mots_uniques sans Dictionary(2).xlsm
    1.1 MB · Affichages: 44
  • Mots_uniques avec Dictionary(2).xlsm
    1.1 MB · Affichages: 37

youns33

XLDnaute Nouveau
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é...
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 926
Membres
101 842
dernier inscrit
seb0390