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

libellule85 · 20 Janvier 2015

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]

DoubleZero · 20 Janvier 2015

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 🙂

job75 · 20 Janvier 2015

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+

gosselien · 20 Janvier 2015

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

libellule85 · 20 Janvier 2015

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

Bonjour DoubleZéro, Job75, gosselien,

Je vous remercie beaucoup pour vos réponses. Je vais les essayer et je vous tiens au courant.
Encore merci

libellule85 · 20 Janvier 2015

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

libellule85 · 21 Janvier 2015

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,

job75 · 21 Janvier 2015

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+

libellule85 · 21 Janvier 2015

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

Bonjour job75,

Une nouvelle fois un grand grand merci pour ton aide.

Bon après midi,

libellule85 · 24 Janvier 2015

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,

job75 · 24 Janvier 2015

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+

libellule85 · 24 Janvier 2015

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

Bonsoir Job75,

Une nouvelle fois un grand merci pour ton aide, c'est vraiment sympa.

Bonne soirée

job75 · 25 Janvier 2015

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.

libellule85 · 25 Janvier 2015

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

Bonjour Job75, le forum,

Merci beaucoup pour cette précision.

Bonne journée

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

libellule85

XLDnaute Accro

Pièces jointes

DoubleZero

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

gosselien

XLDnaute Barbatruc

libellule85

XLDnaute Accro

libellule85

XLDnaute Accro

libellule85

XLDnaute Accro

Pièces jointes

job75

XLDnaute Barbatruc

libellule85

XLDnaute Accro

libellule85

XLDnaute Accro

job75

XLDnaute Barbatruc

libellule85

XLDnaute Accro

job75

XLDnaute Barbatruc

libellule85

XLDnaute Accro

Discussions similaires

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

XLDnaute Accro

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Accro

XLDnaute Accro

Pièces jointes

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

Discussions similaires

Privacy & Transparency

Privacy & Transparency