Supprimer des mots en double

klip89

XLDnaute Nouveau
Bonjour,

je cherche comment faire pour supprimer dans excel des mots qui apparaissent en double ou triple dans une colonne

exemple :

Dans ma colonne A, j'ai un mot par ligne mais plusieurs fois le même dans mes 9 lignes et je voudrais trouver le moyen de supprimer tous les mots en double ou en triple, exemple :

ligne 1 : THYM
ligne 2 : COURGES
ligne 3 : RAVES
ligne 4 : NOIX
ligne 5 : COURGES
ligne 6 : NOIX
ligne 7 : COURGES
ligne 8 : RAVES
ligne 9 : THYM

Je cherche donc comment supprimer les mots qui doublent et triplent pour ne garder qu'une seule fois courges, thym, noix, raves

je suis nouvelle et ne sait pas me servir d'excel, merci d'avance pour votre aide
 

atlonia

XLDnaute Occasionnel
Re : Supprimer des mots en double

Bonsoir clip89,

Voici la macro que j'utilise:

Private Sub SupprimeDoublons(FeuilleATraiter As String, ColonneATraiter As Byte)
Dim i As Integer, j As Integer, DLV1 As Integer
DLV1 = Sheets(FeuilleATraiter).Columns(ColonneATraiter).Find("", , , , xlByRows, xlNext).Row - 1
For i = DLV1 To 2 Step -1
For j = i - 1 To 1 Step -1
If Sheets(FeuilleATraiter).Cells(i, ColonneATraiter).Value = Sheets(FeuilleATraiter).Cells(j, ColonneATraiter).Value Then _
Sheets(FeuilleATraiter).Cells(j, ColonneATraiter).Delete Shift:=xlUp
Next j
Next i
End Sub
Sub SuppressionDesdoublons()
' SUPPRESSION des valeurs en doublon de la colonne A de la Feuille 1
Call SupprimeDoublons("Feuil1", 1)
End Sub
 

Staple1600

XLDnaute Barbatruc
Re : Supprimer des mots en double

Bonsoir



Tu peux essayer le filtre élaboré avec Extraction sans doublons.

1) Tu sélectionnes tes données
2) Aller dans le menu : Données/Filtre/Filtre Elaboré
3) Choisir [Filtrer sur place] et cocher [Extraction sans doublons]

Tu peux à l'étape 3 choisir également [Copier vers un emplacement]

Regardes dans le ficher exemple joint.

(Les 2 boutons gris sont cliquables)
 
Dernière édition:

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : Supprimer des mots en double

Bonjour,

Code:
Sub supdoublons()
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set champ = Range("A1:A" & [A65000].End(xlUp).Row)
  For i = [A65000].End(xlUp).Row To 1 Step -1
    If Application.CountIf(champ, Cells(i, 1)) > 1 Then
      Cells(i, 1).Delete Shift:=xlUp  ' ou Rows(i).Delete
    End If
  Next i
  Application.Calculation = xlAutomatic
End Sub

Sub supdoublons2()
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  For i = [A65000].End(xlUp).Row To 2 Step -1
    Set result = Range("A1:A" & i - 1).Find(What:=Cells(i, 1), LookIn:=xlValues, Lookat:=xlWhole)
    If Not result Is Nothing Then
      Cells(i, 1).Delete Shift:=xlUp  ' ouRows(i).Delete
    End If
  Next i
  Application.Calculation = xlAutomatic
End Sub

JB
 

Pièces jointes

  • SupDoublons.xls
    29.5 KB · Affichages: 206
Dernière édition:

Discussions similaires

Réponses
26
Affichages
856

Statistiques des forums

Discussions
312 147
Messages
2 085 768
Membres
102 969
dernier inscrit
pizza