Macro pour doublons

  • Auteur de la discussion Temjeh
  • Date de début
T

Temjeh

Guest
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
 
Z

Zon

Guest
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+++
 
T

Temjeh

Guest
Wow ou as-tu pris ca?

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

Merci beacoup Zon
 
Z

Zon

Guest
Re,

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

A+++
 
J

jean phi13

Guest
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
 
M

myDearFriend

Guest
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
 
J

jean phi13

Guest
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
 
Z

Zon

Guest
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+++
 
A

Art

Guest
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
 
M

myDearFriend

Guest
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
 

Fichiers joints

A

Art

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

myDearFriend

Guest
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
 

Fichiers joints

A

Art

Guest
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
 
M

Merwan

Guest
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 ;)
 
M

myDearFriend

Guest
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
 

Fichiers joints

M

myDearFriend

Guest
Bonsoir tout le monde,

Notre ami Salim (merci à lui) vient de m'informer d'un problème avec la macro complémentaire que j'ai fournie.

En effet, si la feuille est entièrement vide ou s'il n'y a qu'une seule donnée renseignée (en A1), la sélection du bouton "Supprimer Doublons" provoque une lamentable erreur !

Je joins donc à ce post, le nouveau fichier rectifié en conséquence...

(arf, on se croirait presque chez Billou avec ces 'services pack') ;-)


Cordialement,
Didier_mDF
 

Fichiers joints

S

salim

Guest
Bonjour le Fil et le Forum

Salut Didier_mDF juste pour te dire que ta macro complémentaire pour doublons fonctionne superbement bien et qu'elle à été remarquablement réalisée. Et pour dire que la vie est ainsi faite sur ce fantastique Forum, en voulant t'aider j'ai appris et quand tu ma répondu j'ai appris d'avantage!.

@+ salim
 
A

art

Guest
Bonjour myDearFriend, bonjour tous

Je te remercie myDearFriend, pour cette .XLA qui est impecable.
@+
Art
 
A

Art

Guest
Re bonjour tous, re myDearFriend

Tu vas peut etre me trouver casse pied, mais après avoir tester ta super macro Doublons il s'avere que je ne peut pas selectionner seulement les colonnes A et C par exemple, je suis obligé d'inclure la colonne B avec mon choix. Est il possible de ne pouvoir selectionner que des colonnes ponctuellement?

Merci encore pour tout ce que vous faites tous et si je progresse, c'est bien grace à vous!!

@+
Art
 
M

myDearFriend

Guest
Bonjour Art,

Heu... en pressant la touche CTRL tu peux sélectioner les items que tu souhaites et uniquement ceux-là ! Comme dans la quasi-totalité des applis Windows, CTRL permet de sélectionner indivuduellement un ou plusieurs éléments consécutifs ou non consécutifs.

A l'opposé, MAJ permet d'étendre une sélection d'un élément à un autre en englobant d'office les intermédiaires...

Conclusion, dans la liste des colonnes du Userform, si tu veux sélectionner uniquement A et C, maintiens la touche CTRL enfoncée et cliques sur les choix que tu veux.

Si le problème ne se situe pas là, tiens-moi informé.


Cordialement,
Didier_mDF
 

Discussions similaires


Haut Bas