Effacer des doublons, s'ils y en a 4

[christ-94]

Bonjour
J’ai a travailler sur 4 bases avec les mêmes champs et même valeur
J’aimerai supprimer les valeurs identique et en faire ressortir que le delta
Pour ce faire ,j’ai récupérer les champs des 4 base , que j’ai mis dans une même colonne
Par contre, je n’arrive pas a faire l’extraction des valeurs qui ne sont pas identiques et puis supprimer les 4 doublons identiques


Exemple

Colonne A 				    Colonne F
mes données		      que l’extraction sans le As car il y est 4 fois

As						De
De						Fe
Fe						Gt
As						
As
Gt
As

Merci d’avance de votre aide

[LE PROBLEME EST RESOLU]
Ci-joint le code

Sub SupprimeDoublons()
Dim cel As Range, lig As Long
Application.ScreenUpdating = False
For Each cel In Range("A1", [A65536].End(xlUp))
If cel <> "" And Application.CountIf([A:A], cel) < 4 Then
lig = lig + 1
cel.Resize(, 4).Copy Cells(lig, "F")
Application.CutCopyMode = False
End If
Next
End Sub

 

[job75]

Re : Effacer des doublons, s'ils y en a 4

Bonjour christ-94, le forum,

Si j'ai bien compris, essayez par exemple cette macro :

Sub SupprimeDoublons()
Dim cel As Range, lig As Long
Application.ScreenUpdating = False
[COLOR="Red"][F:F].ClearContents[/COLOR]
For Each cel In Range("A1", [A65536].End(xlUp))
  If cel <> "" And Application.CountIf([A:A], cel) < 4 Then
    lig = lig + 1
    Cells(lig, "F") = cel
  End If
Next
End Sub

Edit 1 : salut Philippe.

Edit 2 : mieux vaut effacer d'abord la colonne F (en rouge).

A+

 

[phlaurent55]

Re : Effacer des doublons, s'ils y en a 4

Bonjour à tous,

sans macro mais il reste des "blancs"

à+
Philippe

 

[christ-94]

Re : Effacer des doublons, s'ils y en a 4

Bonjour et merci pour les réponses

je viens de faire un test rapide de la solution de job75
elle fonctionne bien 🙂, par contre j'ai besoin de récupère dans la colonne F
"la colonne A , B et C" cette solution ne récupère que la valeur de la colonne A
"cela n'était pas précise, cela est de ma faute"
je suis désole d'abuse 😱

Merci encore

 

[phlaurent55]

Re : Effacer des doublons, s'ils y en a 4

Re,
voir pièce jointe

à+

 

[BZH56]

Re : Effacer des doublons, s'ils y en a 4

bonjour le fil et chris
ci joint une autre solution qui trie sur la colonne a qui contient toutes les valeurs et n affiche ensuite que les valeurs uniques

Sub suppressiondoublons()
    Dim cellulecourante As Range
    Dim cellulesuivante As Range
    Set cellulecourante = ActiveSheet.Range("a2")
'Tri des données
    ActiveSheet.Range("a2").Sort key1:=Range("a2"), order1:=xlAscending, _
    Header:=xlGuess
'boucle
    Do While Not IsEmpty(cellulecourante) = True
      Set cellulesuivante = cellulecourante.Offset(1, 0)
      If cellulesuivante.Value = cellulecourante.Value Then
         cellulecourante.EntireRow.Delete
      End If
    Set cellulecourante = cellulesuivante
    Loop
 
End Sub

si cela peut t avancer dans ta recherche de solution 🙂

 

[christ-94]

Re : Effacer des doublons, s'ils y en a 4

Bonjour phlaurent55, merci pour cette réponse

par contre j'ai le même problème qu'avec la solution de job75, je ne récupère que la colonne A
et de plus , je suis incapable d'utilise cette formule, car ce problème n'ai qu'un bout du code , qui doit être intègre dans des modules en VBA

Merci encore

 

[christ-94]

Re : Effacer des doublons, s'ils y en a 4

Bonjour

Merci BZH56 pour ta participation 😉

Je viens de teste ta macro , le problème c'est qu'elle n'efface pas tous les doublons

exemple
si j'ai en colonne A
1
2
2
2
2

le résultat doit être
1

car tous les 2 sont effacé
en plus elle supprime tout les doublons meme s'il y en que 2
Les doublons doivent etre supprimé s'ils y en a 4

Merci
encore

 

[job75]

Re : Effacer des doublons, s'ils y en a 4

Re,

Le nouveau problème est mal défini car on ne sait pas si l'on doit éliminer les doublons comptés sur une même colonne ou sur la plage A:C.

1) Sur une même colonne :

Sub SupprimeDoublons()
Dim i As Byte, cel As Range, lig As Long
Application.ScreenUpdating = False
[F:F].ClearContents
For i = 0 To 2
  For Each cel In Range([A1].Offset(, i), [A65536].Offset(, i).End(xlUp))
    If cel <> "" And Application.CountIf([COLOR="Red"][A:A].Offset(, i)[/COLOR], cel) < 4 Then
      lig = lig + 1
      Cells(lig, "F") = cel
    End If
  Next
Next
End Sub

2) Sur la plage A:C :

Sub SupprimeDoublons()
Dim i As Byte, cel As Range, lig As Long
Application.ScreenUpdating = False
[F:F].ClearContents
For i = 0 To 2
  For Each cel In Range([A1].Offset(, i), [A65536].Offset(, i).End(xlUp))
    If cel <> "" And Application.CountIf([COLOR="Red"][A:C][/COLOR], cel) < 4 Then
      lig = lig + 1
      Cells(lig, "F") = cel
    End If
  Next
Next
End Sub

A+

 

[christ-94]

Re : Effacer des doublons, s'ils y en a 4

Bonjour

Merci pour la réponse , désole de ne pas l'avoir teste plutôt

Je souhaite utilise ce code qui fonctionne très bien

Sub SupprimeDoublons()
Dim cel As Range, lig As Long
Application.ScreenUpdating = False
[F:F].ClearContents
For Each cel In Range("A1", [A65536].End(xlUp))
  If cel <> "" And Application.CountIf([A:A], cel) < 4 Then
    lig = lig + 1
    Cells(lig, "F") = cel
  End If
Next
End Sub

le resultat est correct

Mais modifier le résultat en F, donc cette ligne de code

      Cells(lig, "F") = cel

pour que le résultat , soit la copie de la colonne A, B, C,D en F
sur la comparaison en A, ou sinon supprimer les lignes qui on les doublons

Merci d'avance

 

[christ-94]

Re : Effacer des doublons, s'ils y en a 4

Re-bonjour

J'ai trouve une solution, qui n'ai pas la meilleur
j'ai fait un filtre élabore

Ci-joint un exemple du code

    Range("A1:C13").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
        "F1:F9"), CopyToRange:=Range("H1:J1"), Unique:=False

cela pose 2 problèmes :
-je ne pense pas que cela soit très fiable, car dans mon tableau il y a environ 4000 lignes
-cela rallonge le temps de traitement

Si quelqu'un trouve un autre solution !

Merci d'avance

 

[david84]

Re : Effacer des doublons, s'ils y en a 4

Bonjour à tous,
ci-joint une proposition par formule.
Si ce n'est pas ce que tu cherches, poste un fichier exemple qui expose clairement ta demande.
A+

 

[christ-94]

Re : Effacer des doublons, s'ils y en a 4

Bonjour merci pour ta proposition

Ci-joint un fichier exemple
Regarde la pièce jointe Elimine_Doublons.zip

Je cherche une solution sous forme de macro

Merci d'avance

 

[david84]

Re : Effacer des doublons, s'ils y en a 4

Re,

Je cherche une solution sous forme de macro

Je ne peux donc rien pour toi.
A+

 

[Staple1600]

Re : Effacer des doublons, s'ils y en a 4

Bonjour christ-4, david84, à tous,

Tu peux modifier la macro de Job75 (que je salue 😉 ) ainsi

Sub SupprimeDoublons()
Dim cel As Range, lig As Long
Application.ScreenUpdating = False
For Each cel In Range("A1", [A65536].End(xlUp))
  If cel <> "" And Application.CountIf([A:A], cel) < 4 Then
    lig = lig + 1
  cel.Resize(, 4).Copy Cells(lig, "F")
  Application.CutCopyMode = False
  End If
Next
End Sub