Macro pour doublons

Bonsoir le Furum

J'ai déja poser ce genre de question mais pas exactement celle-là

Dans une feuil1 je veut sélectionner les col 1,2,3 (avec macro)et supprimer tout les doublons de la colonne 1 et supprimer leur ligne en même temps.

J'ai essayé avec filtre élaboré mais ca marche pas trop car il cache les doublon ne les suppriment pas!! puis il y a un ptit bug en sélection multiple

Merci beaucoup pour votre aide

Temjeh

Salut,

Colles ceci dans un module standard:

Sub Princ()
Dim Plage As Range
Dim T
Set Plage = Range([A1], [C65536].End(xlUp)) 'à adapter
T = Doublons(Plage.Value, 1) 'Doublons sure la 1 ere colonne
If IsArray(T) Then
T = InverseTab(T, 1)
With Plage
.clear
.Cells(1,1).Resize(UBound(T), UBound(T, 2)) = T
end with
Else: MsgBox T
End If
End Sub


Function Doublons(T, ColT As Byte) 'Zon
Dim I&, J&, K&, Tablo As New Collection
Dim Temp()
For I = LBound(T, 1) To UBound(T, 1)
On Error Resume Next
Tablo.Add T(I, ColT), CStr(T(I, ColT))
If Err = 0 Then
ReDim Preserve Temp(1 To UBound(T, 2), 1 To J + 1)
For K = 1 To UBound(Temp)
Temp(K, J + 1) = T(I, K)
Next K
J = J + 1
End If
Next I
Doublons = IIf(J > 0, Temp, "Pas de doublons")
End Function
Function InverseTab(T, Optional Base As Byte = 0)
Dim Temp(), I&, J&
ReDim Temp(Base To UBound(T, 2), Base To UBound(T))
For I = LBound(T, 2) To UBound(T, 2)
For J = LBound(T) To UBound(T)
Temp(I, J) = T(J, I)
Next J
Next I
InverseTab = Temp
End Function

A+++

Wow ou as-tu pris ca?

Ca fonctionne très bien et tout cela en 10minutes!!!!!!

Merci beacoup Zon

Re,

Le code met 10 minutes pfff mets le calcul en manuel .

A+++

Bonsoir tout le monde
Bonsoir Zon

Débutant en excel, macro et vba
Je viens de découvrir ce code qui m'intéresse à une nuance près. Je m'explique:
J'ai des données sur une feuille.
Chaque enregistrement comporte 9 champs, donc neuf colonnes.
Recevant des mises à jour de mes données, j'ai de nombreux enregistrements en double (c'est à dire les 9 colonnes identiques)
Pourrait-on aménager ton code pour la recherche des doublons ne se fasse pas que sur la colonne A mais sur au moins les 7 premieres colonnes qui déterminent si mon enregistrement est identique au précédent)

Merci par avance pour vos réponses.
Jean Phi13

Bonsoir Temjeh, Zon, Jean phi, le Forum.


Jean phi, je te propose le code ci-dessous associé à un bouton nommé "btnDoublons" et placé sur ta feuille :

Option Base 1

Private Sub btnDoublons_Click()
Dim L As Long
Dim TabTemp As Variant
Dim TabTemp2() As Variant
Dim Db As New Collection
Dim Nc As Byte
Dim C As Byte

With ActiveSheet
L = .Range("A65536").End(xlUp).Row
C = .Range("A1").SpecialCells(xlLastCell).Column

Nc = Val(InputBox("Sur combien de colonnes ?", "Elimination des Doublons", "10"))
If Nc < 1 Or Nc > C Then Exit Sub
'Mémoriser les données dans un tableau variant temporaire
TabTemp = .Range(.Cells(1, 1), .Cells(L, C)).Value
ReDim TabTemp2(UBound(TabTemp, 1), 2)
'Concaténer les colonnes de données dans un tableau variant temporaire
For L = 1 To UBound(TabTemp, 1)
For C = 1 To Nc
TabTemp2(L, 1) = TabTemp2(L, 1) & CStr(TabTemp(L, C))
Next C
Next L
'Détecter les doublons (méthode de J.Walkenbach)
On Error GoTo Doublons:
For L = 1 To UBound(TabTemp2, 1)
Db.Add TabTemp2(L, 1), CStr(TabTemp2(L, 1))
Next L
On Error GoTo 0
'Supprimer les lignes de doublons dans la feuille
For L = UBound(TabTemp2, 1) To 1 Step -1
If TabTemp2(L, 2) > 0 Then
.Rows(L).EntireRow.Delete
End If
Next L
End With
Exit Sub

Doublons:
TabTemp2(L, 2) = 1
Resume Next
End Sub

Ca te laisse la possibilité de choisir le nombre de colonnes à partir desquelles il faut chercher les doublons...


Cordialement,
Didier_mDF

Bonjour le forum
Bonjour Temjeh, Zon, Didier

Merci Didier pour cette réponse qui répond tout à fait à mon attente.
Je vais ainsi gagner des heures fastidieuses de travail, avec en plus des risques de supprimer des enrregistrements non doublons.

Merci encore à toi Didier, à tous d'ailleurs.

Bon dimanche à tous
Jean Phi

Salut,

Si la mêthode reste la même, je passe uniquement par des tableaux VBA, comme cela on écrit qu'une fois dans la feuille de calcul(ce qui est le plus long d'ailleurs).
Même si le code est plus long en nombre de lignes que didier il est par contre beaucoup plus rapide à l'éxécution.
J'ai mis une constante pour le nombre de colonnes, ici 7 mais on peut travailler de 2 j'usqu'à 256 colonnes. tu peut reprendre l'inputbox de didier si tu ne veux pas travailler toujours sur 7 colonnes.

Option Explicit
Const Nbcol As Byte = 7
Const Sep$ = "~" 'suivant les données adapter le caractère d'espacement.

Sub Princ()
Dim Plage As Range, T
Set Plage = Range([A2], [I65536].End(xlUp)) 'à adapter
T = Concatener(Plage.Value)
T = Doublons(T, 1)
If IsArray(T) Then
T = DeconcaTener(T, UBound(Plage.Value, 2))
T = InverseTab(T, 1)
With Plage
.Clear 'supprimer le commentaire aprés les tests
.Cells(1, 1).Resize(UBound(T), UBound(T, 2)) = T
End With
Else: MsgBox T
End If
End Sub

Function Concatener(T)
Dim I&, J&, Temp
ReDim Temp(1 To UBound(T), 1 To 1 + (UBound(T, 2) - Nbcol))
For I = LBound(T) To UBound(T)
For J = 1 To Nbcol
Temp(I, 1) = Temp(I, 1) & Sep & T(I, J)
Next J
For J = Nbcol + 1 To UBound(T, 2)
Temp(I, J - 1) = T(I, J)
Next J
Next I
Concatener = Temp
End Function

Function Doublons(T, ColT As Byte) 'Zon
Dim I&, J&, K&, Tablo As New Collection
Dim Temp()
For I = LBound(T, 1) To UBound(T, 1)
On Error Resume Next
Tablo.Add T(I, ColT), CStr(T(I, ColT))
If Err = 0 Then
ReDim Preserve Temp(1 To UBound(T, 2), 1 To J + 1)
For K = 1 To UBound(Temp)
Temp(K, J + 1) = T(I, K)
Next K
J = J + 1
End If
Next I
Doublons = IIf(J > 0, Temp, "Pas de doublons")
End Function

Function DeconcaTener(T, N As Byte)
Dim I&, J&, K&, Temp(), Tablo
K = 1
For I = LBound(T, 2) To UBound(T, 2)
Tablo = Split(T(1, I), Sep)
ReDim Preserve Temp(1 To N, 1 To K)
For J = LBound(Tablo) + 1 To UBound(Tablo)
Temp(J, K) = Tablo(J)
Next J
For J = Nbcol + 1 To N
Temp(J, K) = T(J - 1, I)
Next J
K = K + 1
Next I
DeconcaTener = Temp
End Function

Function InverseTab(T, Optional Base As Byte = 0)'Zon
Dim Temp(), I&, J&
ReDim Temp(Base To UBound(T, 2), Base To UBound(T))
For I = LBound(T, 2) To UBound(T, 2)
For J = LBound(T) To UBound(T)
Temp(I, J) = T(J, I)
Next J
Next I
InverseTab = Temp
End Function

=>>>Si tu as Xl97 remplaces split par splitzon97

Function SplitZon97(ByVal Ch$, Sep$)
Dim Pos&, PosS&, T(), I&
Pos = 1
Do
PosS = InStr(Pos, Ch, Sep)
ReDim Preserve T(I)
On Error Resume Next
T(I) = Mid(Ch, Pos, PosS - Pos)
If Err <> 0 Then
Pos = Pos - 1
T(I) = Right(Ch, Len(Ch) - Pos)
Exit Do
End If
Pos = PosS + 1
I = I + 1
Loop While PosS > 0
SplitZon97 = T
End Function

A+++

Bonjour à tous, forummeuses, forummeurs.
Excuser moi de m'incruster dans ce fil mais ces macros m'interressent particulièrement.
Serait il possible en partant de ces macros, d'avoir un inputbox en debut de macro, me donnant le choix sur les colonnes à tester?
Je bloque dessus depuis un certain temps et ce fil me permettra peut etre d'avoir une reponse.
Merci à vous tous pour les progrès que j'ai fait grace à vous.
@+
Art

Bonsoir Art, le Forum.

J'ai trouvé ta question très intéressante Art.

Je te propose l'exemple ci-joint dans lequel j'ai ajouté un USF avec une liste multisélections qui permet de choisir les colonnes qui devront participer à la recherche des doublons...

Le principe restant toujours le même.

Cordialement,
Didier_mDF

Super myDearFriend
Je m'en vais de ce pas essayer ton petit bijou et je reviens vers toi pour te dire.
@+
Art

Re- Art, le Forum.

Oups !

Désolé Art, le «bijou» que j'avais joint ne vaut pas un kopeck !!!
Heu.... j'«écrin» qu'il y ait un beau plantage si l'on choisit une colonne extérieure au tableau de données LOL ...

Tu trouveras ci-joint une nouvelle version retaillée de ce bijou de pacotille !

Avec toutes mes excuses.

Cordialement,
Didier_mDF

Bonjour à tous, bonjour myDearFriend
Pas de problème myDearFriend, merci d'etre revenue si vite alors que je n'avais meme pas eu le temps de tester la premiere version.
Je teste la deuxieme et je reviens.
@+
Art

Bonjour à tous,
elle est franchement bien faite cette macro, bravo myDearFriend

Je me demandais juste, pour des questions pratiques si on pouvait déplacer le bouton "MyDearFriend!" vers la gauche et eventuellement qu'il y reste, meme si on fait defiler l'ecran, je me perd ds les lignes de code

Bonsoir tout le monde,

Merwan, pour moi, le meilleur moyen d'avoir le bouton à dispo c'est de le mettre dans la barre d'outils. Comme ça, plus de problème !

Le classeur est devenu une macro complémentaire ".xla" que tu trouveras ci-joint.

Tu auras 2 façons de faire à ta disposition :

1) La première est de lancer le fichier ponctuellement, tu l'ouvriras donc dans Excel (comme n'importe quel classeur "classique") lorque tu en auras besoin.

2) La deuxième consiste à le faire charger automatiquement à chaque démarrage d'Excel pour l'avoir ainsi tout le temps à disposition :
- Tu enregistres ce fichier ".xla" dans ton répertoire de Macros Complémentaires
- Tu lances Excel, puis tu fais Outils/Macros Complémentaires
- Tu coches "mDF_Doublons", puis OK.

Dans les 2 cas, un nouveau bouton intitulé "Doublons" apparaît maintenant dans la barre d'outils Excel. Un clic dessus et la macro s'exécutera sur la feuille active.


Cordialement,
Didier_mDF