supprimer toutes les cellules qui se répètent au moins 2 fois

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
libellule85

libellule85

XLDnaute Accro
Bonjour le forum,

Je recherche une macro qui puisse supprimer toutes les cellules identiques d'une colonne, par exemple :

[TABLE="width: 104"]
[TR]
[TD="class: xl65, width: 104"]tata[/TD]
[/TR]
[TR]
[TD="class: xl65"]toto[/TD]
[/TR]
[TR]
[TD="class: xl65"]tutu[/TD]
[/TR]
[TR]
[TD="class: xl65"]titi[/TD]
[/TR]
[TR]
[TD="class: xl65"]tata[/TD]
[/TR]
[TR]
[TD="class: xl65"]toto[/TD]
[/TR]
[/TABLE]

Il ne doit rester que tutu et titi, macro qui doit aussi faire les nombres.

D'avance je vous remercie pour votre aide.

[TD="class: xl63"][/TD]
 

Pièces jointes

Trier par date Trier par votes
Re : supprimer toutes les cellules qui se répètent au moins 2 fois

Bonjour, libellule85, le Forum,

Une suggestion avec le code ci-après :

Code: 
Option Explicit
Sub Valeurs_uniques_conserver()
    Dim i As Long
    Application.ScreenUpdating = False
    Columns("a:a").Insert
    With Range("a2:a" & Cells(Rows.Count, 2).End(xlUp).Row)
        .FormulaR1C1 = "=COUNTIF(C[1],RC[1])"
        .Value = .Value
    End With
    For i = Cells(Rows.Count, "a").End(xlUp).Row To 2 Step -1
        If Range("a" & i) <> 1 Then Rows(i).Delete
    Next i
    Columns("a:a").Delete
    Application.ScreenUpdating = True
End Sub

A bientôt 🙂
 
Vote positif 0 Vote négatif
Re : supprimer toutes les cellules qui se répètent au moins 2 fois

Bonjour libellule85, DoubleZero 🙂

S'il y a beaucoup de données mieux vaut utiliser des tableaux VBA, c'est bien plus rapide :

Code: 
Sub Nettoyage()
Dim t, dest As Range, d As Object, e, a, b, i&, n&, rest()
t = Range("A2", Range("A" & Rows.Count).End(xlUp)(3)) 'au moins 2 éléments
Set dest = [A2] 'cellule de restitution, à adapter éventuellement
Set d = CreateObject("Scripting.Dictionary")
For Each e In t
  If e <> "" Then d(e) = d(e) + 1
Next
If d.Count Then
  a = d.keys: b = d.items
  For i = 0 To UBound(a)
    If b(i) > 1 Then d.Remove a(i)
  Next
  n = d.Count
End If
If n Then
  '---transposition---
  a = d.keys
  ReDim rest(1 To n, 1 To 1)
  For i = 0 To UBound(a)
    rest(i + 1, 1) = a(i)
  Next
  '---restitution---
  dest.Resize(n) = rest
End If
dest.Offset(n).Resize(dest.Parent.Rows.Count - dest.Row - n + 1).Delete xlUp
End Sub
A+
 
Vote positif 0 Vote négatif
Re : supprimer toutes les cellules qui se répètent au moins 2 fois

Bonjour le forum,Job et 00,

ceci fonctionne aussi et copie les données uniques 2e colonne à droite si elle est bien vide..
Perso, je l'ai toujours dans le clic droit de ma souris

Sub ValUniquesDansColonneaDroite() ' PlageSrc As Range, CellDest As Range)
'Extrait les valeurs uniques d'une colonne et les renvoie
'dans une autre, à partir de CellDest tiré d'un code de F. Signonneau
Dim Arr1, Elt, Arr2(), Coll As New Collection, i As Integer
'If PlageSrc.Columns.Count > 1 Then Exit Sub '
'Arr1 = PlageSrc.Value
Arr1 = Selection.Value
Dim Colo
Dim line
Dim err
Colo = Selection.Column
line = Selection.Row
For Each Elt In Arr1
If Not Application.CountA(Columns(Colo + 2)) = 0 Then
MsgBox ("2e Colonne à droite non vide, sortie de la fonction !")
Exit Sub
End If
On Error Resume Next
Coll.Add Elt, CStr(Elt)
If err.Number = 0 Then
ReDim Preserve Arr2(1 To Coll.Count)
Arr2(Coll.Count) = Elt
End If
On Error GoTo 0
Next
For i = 1 To Coll.Count
If IsEmpty(Cells(line, Colo + 1)) Then
Cells(line + i, Colo + 1).Value = Coll.Item(i)
Else
MsgBox ("cellule voisine non vide, sortie du code")
Exit Sub
End If
Next
Application.Transpose (Arr2)
End Sub

' ici le code pour clic droit dans la souris

Sub MenuCell()
Dim Ctrl
For Each Ctrl In Application.CommandBars("Cell").Controls
'Ctrl.Enabled = True
Application.CommandBars("Cell").Reset

Next
With Application.CommandBars("Cell").Controls.Add(msoControlButton)
.Caption = "Copier occurence unique à la droite de la colonne actuelle"
.BeginGroup = True
.FaceId = 2533
.OnAction = "ValUniquesDansColonneaDroite"
End With
End Sub
 
Vote positif 0 Vote négatif
Re : supprimer toutes les cellules qui se répètent au moins 2 fois

Re,

@ DoubleZero, Job75 : c'est exactement ce que je recherchais, encore merci pour votre aide

@ gosselien : ta macro fonctionne impeccable, mais le résultat attendu ne correspond pas. En effet, je voulais supprimer toutes cellules qui se répétaient au moins deux fois. Le résultat attendu était dans mon exemple tutu et titi. En tous cas je te remercie beaucoup pour t'être intéressé de ma demande.

Bonne soirée à vous
 
Vote positif 0 Vote négatif
Re : supprimer toutes les cellules qui se répètent au moins 2 fois

Bonjour Job75, le forum,

Je reviens vers vous car j'ai utilisé votre macro (ci-dessous) mais elle ne fonctionne pas dans le fichier ci-joint.

Code: 
Sub Nettoyage()
Dim t, dest As Range, d As Object, e, a, b, i&, n&, rest()
t = Range("A2", Range("A" & Rows.Count).End(xlUp)(3)) 'au moins 2 éléments
Set dest = [A2] 'cellule de restitution, à adapter éventuellement
Set d = CreateObject("Scripting.Dictionary")
For Each e In t
  If e <> "" Then d(e) = d(e) + 1
Next
If d.Count Then
  a = d.keys: b = d.items
  For i = 0 To UBound(a)
    If b(i) > 1 Then d.Remove a(i)
  Next
  n = d.Count
End If
If n Then
  '---transposition---
  a = d.keys
  ReDim rest(1 To n, 1 To 1)
  For i = 0 To UBound(a)
    rest(i + 1, 1) = a(i)
  Next
  '---restitution---
  dest.Resize(n) = rest
End If
dest.Offset(n).Resize(dest.Parent.Rows.Count - dest.Row - n + 1).Delete xlUp
End Sub

Et ne maitrisant pas trop les macros.... J'aurais peut-être dû modifier celle-ci pour qu'elle fonctionne mais je ne sais pas où.

Une nouvelle fois merci pour votre aide.

Cordialement,
 

Pièces jointes

Vote positif 0 Vote négatif
Re : supprimer toutes les cellules qui se répètent au moins 2 fois

Bonjour libellulle85, le forum,

Bah il y a des espaces insécables de code 160, qui plus est superflus 😱

Il est facile de les remplacer par de vrais espaces :

Code: 
Sub Nettoyage()
Dim t, dest As Range, d As Object, e, a, b, i&, n&, rest()
t = Range("A2", Range("A" & Rows.Count).End(xlUp)(3)) 'au moins 2 éléments
Set dest = [A2] 'cellule de restitution, à adapter éventuellement
Set d = CreateObject("Scripting.Dictionary")
For Each e In t
  e = Application.Trim(Replace(e, Chr(160), " ")) 'remplace les espaces insécables
  If e <> "" Then d(e) = d(e) + 1
Next
If d.Count Then
  a = d.keys: b = d.items
  For i = 0 To UBound(a)
    If b(i) > 1 Then d.Remove a(i)
  Next
  n = d.Count
End If
If n Then
  '---transposition---
  a = d.keys
  ReDim rest(1 To n, 1 To 1)
  For i = 0 To UBound(a)
    rest(i + 1, 1) = a(i)
  Next
  '---restitution---
  dest.Resize(n) = rest
End If
dest.Offset(n).Resize(dest.Parent.Rows.Count - dest.Row - n + 1).Delete xlUp
End Sub
A+
 
Vote positif 0 Vote négatif
Re : supprimer toutes les cellules qui se répètent au moins 2 fois

Bonsoir le forum, Job75,

J'aimerais améliorer ton code (qui fonctionne à merveille) en vérifiant non plus sur une mais sur sur deux colonnes (A et B) que les lignes ne se répètent pas au moins 2 fois


Code: 
Sub Nettoyage()

'Code fait par Job75

Dim t, dest As Range, d As Object, e, a, b, i&, n&, rest()
t = Range("A5", Range("A" & Rows.Count).End(xlUp)(3)) 'au moins 2 éléments
Set dest = [A5] 'cellule de restitution, à adapter éventuellement
Set d = CreateObject("Scripting.Dictionary")
For Each e In t
  e = Application.Trim(Replace(e, Chr(160), " ")) 'remplace les espaces insécables
  If e <> "" Then d(e) = d(e) + 1
Next
If d.Count Then
  a = d.keys: b = d.items
  For i = 0 To UBound(a)
    If b(i) > 1 Then d.Remove a(i)
  Next
  n = d.Count
End If
If n Then
  '---transposition---
  a = d.keys
  ReDim rest(1 To n, 1 To 1)
  For i = 0 To UBound(a)
    rest(i + 1, 1) = a(i)
  Next
  '---restitution---
  dest.Resize(n) = rest
End If
dest.Offset(n).Resize(dest.Parent.Rows.Count - dest.Row - n + 1).Delete xlUp
End Sub

D'avance je vous remercie de votre aide,
 
Vote positif 0 Vote négatif
Re : supprimer toutes les cellules qui se répètent au moins 2 fois

Bonsoir libellule85,

Code: 
Sub Nettoyage()
Dim t, dest As Range, d As Object, i&, e, a, b, n&, rest(), s
t = Range("A5:B" & Range("A" & Rows.Count).End(xlUp)(5).Row)
Set dest = [A5] 'cellule de restitution, à adapter éventuellement
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t)
  e = Application.Trim(Replace(t(i, 1), Chr(160), " ")) & _
    Chr(1) & Application.Trim(Replace(t(i, 2), Chr(160), " "))
  d(e) = d(e) + 1
Next
If d.Count Then
  a = d.keys: b = d.items
  For i = 0 To UBound(a)
    If b(i) > 1 Then d.Remove a(i)
  Next
  n = d.Count
End If
If n Then
  '---conversion---
  a = d.keys
  ReDim rest(1 To n, 1 To 2)
  For i = 0 To UBound(a)
    s = Split(a(i), Chr(1))
    rest(i + 1, 1) = s(0)
    rest(i + 1, 2) = s(1)
  Next
  '---restitution---
  dest.Resize(n, 2) = rest
End If
dest.Offset(n).Resize(dest.Parent.Rows.Count - dest.Row - n + 1, 2).Delete xlUp
End Sub
A+
 
Vote positif 0 Vote négatif
Re : supprimer toutes les cellules qui se répètent au moins 2 fois

Bonjour libellule85, le forum,

Noter que par défaut Dictionary tient compte de la casse (majuscules et minuscules respectées).

Si l'on veut que la casse soit ignorée utiliser :

Code: 
'-----
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = 1 'pour ignorer la casse
'-----
Bonne journée.
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

S
  • Résolu(e)
XL 2010 Attribuer ou Changer la valeur d'une cellule en validation de données
2
Réponses
19
Affichages
2 K
Sirberthoult
S
E
  • Question Question
Microsoft 365 Afficher onglets quand toutes les questions sont répondues
2
Réponses
20
Affichages
1 K
Erakmur
E
A
  • Question Question
Autres PB sur Formule CNUM(SUBSTITUTE ...) Nombres avec des espace
Réponses
10
Affichages
413
Armand11
A
B
  • Résolu(e)
XL 2021 compter les cellules de la même couleur
2 3
Réponses
36
Affichages
2 K
mapomme
mapomme
V
  • Question Question
XL 2021 Décalé les cellules
2 3
Réponses
30
Affichages
752
vgendron
vgendron
C
  • Résolu(e)
Power Query POWER QUERY Supprimer des lignes suivant critères
Réponses
3
Affichages
2 K
alexga78
A
A
  • Question Question
Microsoft 365 Extraire chaine qui se répète
Réponses
10
Affichages
510
danielco
D
D
  • Question Question
Microsoft 365 Selectionner toutes les cellules contenant @
Réponses
2
Affichages
330
DELATTE
D
M
  • Résolu(e)
XL 2013 Macross supprimant les données de cellule en dehors d'une période définie dans deux autres cellules
Réponses
9
Affichages
791
MarineU
M
T
  • Résolu(e)
XL 2013 Harmoniser valeur de cellules selon 2 variables
Réponses
4
Affichages
389
Thomas75
T
O
  • Question Question
XL 2013 Planification automatique des rdv d'intervention en fonction des dates disponibles
Réponses
3
Affichages
429
cathodique
cathodique
D
  • Résolu(e)
Microsoft 365 Assistance pour optimisation d'un code VBA qui ne fonctionne pas comme souhaité
2
Réponses
21
Affichages
963
desto
D
P
  • Question Question
XL 2019 Macro VBA appliquer un filtre lors d'une importation de données
Réponses
1
Affichages
531
fanch55
fanch55
P
  • Question Question
XL 2016 VBA Appliquer un filtre sur mes données importées
Réponses
4
Affichages
653
sousou
sousou
D
  • Résolu(e)
Microsoft 365 MFC sur des cellules au format hh:mm:ss
Réponses
4
Affichages
294
Daffy02
D
B
  • Résolu(e)
Microsoft 365 Verifier les données par une formule
Réponses
8
Affichages
364
blancolie
B
jeff1494
  • Question Question
XL 2021 Comment supprimer des noms du gestionnaire de noms dans un classeur
Réponses
7
Affichages
950
jeff1494
jeff1494
C
  • Question Question
Microsoft 365 je cherche un code excel pour copier la couleur d'une cellule, à toutes les cellules qui ont la même valeur dans mon tableau.
Réponses
1
Affichages
478
sylvanu
sylvanu
B
  • Résolu(e)
XL 2021 Séparer les adresses (Rue et N°) en 2 cellules avec un macro
2
Réponses
20
Affichages
2 K
Banbara
B
Calvus
  • Question Question
Microsoft 365 Recherche incomplète planning (problème de dates)
Réponses
13
Affichages
736
p56
p56
Retour